diff --git a/COPYING.LIB b/COPYING.LIB new file mode 100644 index 0000000..eb685a5 --- /dev/null +++ b/COPYING.LIB @@ -0,0 +1,481 @@ + GNU LIBRARY GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1991 Free Software Foundation, Inc. + 675 Mass Ave, Cambridge, MA 02139, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the library GPL. It is + numbered 2 because it goes with version 2 of the ordinary GPL.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Library General Public License, applies to some +specially designated Free Software Foundation software, and to any +other libraries whose authors decide to use it. You can use it for +your libraries, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if +you distribute copies of the library, or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link a program with the library, you must provide +complete object files to the recipients so that they can relink them +with the library, after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + Our method of protecting your rights has two steps: (1) copyright +the library, and (2) offer you this license which gives you legal +permission to copy, distribute and/or modify the library. + + Also, for each distributor's protection, we want to make certain +that everyone understands that there is no warranty for this free +library. If the library is modified by someone else and passed on, we +want its recipients to know that what they have is not the original +version, so that any problems introduced by others will not reflect on +the original authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that companies distributing free +software will individually obtain patent licenses, thus in effect +transforming the program into proprietary software. To prevent this, +we have made it clear that any patent must be licensed for everyone's +free use or not licensed at all. + + Most GNU software, including some libraries, is covered by the ordinary +GNU General Public License, which was designed for utility programs. This +license, the GNU Library General Public License, applies to certain +designated libraries. This license is quite different from the ordinary +one; be sure to read it in full, and don't assume that anything in it is +the same as in the ordinary license. + + The reason we have a separate public license for some libraries is that +they blur the distinction we usually make between modifying or adding to a +program and simply using it. Linking a program with a library, without +changing the library, is in some sense simply using the library, and is +analogous to running a utility program or application program. However, in +a textual and legal sense, the linked executable is a combined work, a +derivative of the original library, and the ordinary General Public License +treats it as such. + + Because of this blurred distinction, using the ordinary General +Public License for libraries did not effectively promote software +sharing, because most developers did not use the libraries. We +concluded that weaker conditions might promote sharing better. + + However, unrestricted linking of non-free programs would deprive the +users of those programs of all benefit from the free status of the +libraries themselves. This Library General Public License is intended to +permit developers of non-free programs to use free libraries, while +preserving your freedom as a user of such programs to change the free +libraries that are incorporated in them. (We have not seen how to achieve +this as regards changes in header files, but we have achieved it as regards +changes in the actual functions of the Library.) The hope is that this +will lead to faster development of free libraries. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, while the latter only +works together with the library. + + Note that it is possible for a library to be covered by the ordinary +General Public License rather than by this special one. + + GNU LIBRARY GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library which +contains a notice placed by the copyright holder or other authorized +party saying it may be distributed under the terms of this Library +General Public License (also called "this License"). Each licensee is +addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also compile or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + c) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + d) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the source code distributed need not include anything that is normally +distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Library General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..7759612 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,328 @@ +02/26/01: rf: change version to 1.7b1 + +02/26/01: rf + - omu/Hqp_Omuses.[hC], omu/Omu_Program.[hC]: + move _ks and _ts from Hqp_Omuses to Omu_Program + - omu/Omu_Program: new public method setup_stages() without + call arguments to be called by Hqp_Omuses; + - omu/Omu_Program: new public methods ts() and ks() + for accessing _ts and _ks + +02/15/01: rf + - hqp/hqp_solve.tcl: introduce hqp_logging to optionally + disable log output + +02/07/01: rf + - add omu/Omu_IntEuler.[hC], extend omu/Makefile, omu/Omu_Init.C + - omu/Omu_IntRK4.C: add support for Omu_Integrator::_stepsize + +01/27/01: rf + - hqp/Hqp_Init.C: disable Meschach's error counting & exit + (call count_errs(0) in Hqp_Init()) + +01/27/01: rf + - omu/Omu_Integrator: introduce _stepsize (prg_int_stepsize) + - omu/Omu_IntDASPK, omu/Omu_IntIMP: implement support for _stepsize + - Makefile, Makefile.hqp: replace "make" with $(MAKE) + (as proposed by Christian Schulz) + +12/05/00: rf: resolve meschach/err.h, catch conflict + - configure.in: change version to 1.7a5 + - rename meschach/err.h to meschach/m_err.h + - m_err.h: rename macro catch to m_catch + - adapt meschach/{matrix.h, err.c, torture.c, ztorture.c, makefile, + version.c} + - hqp/Meschach.h: don't need to redefine catch anymore + - hqp/Hqp_IpsMehrotra.C, hqp/HqpIpsFranke.C: use m_catch + +12/03/00: rf + - configure.in: change version to 1.7a4 + - iftcl/If.[hC], hqp_docp/Docp_Main.C: change name "Float" to "Real" + - iftcl: add If_Real.h, If_RealVec.h, If_RealMat.h + (should be used instead of If_Float* includes and types) + +12/01/00: rf + - configure.in: change version to 1.7a3 + +12/01/00: rf + - moved PERMP from hqp/t_mesch.h to hqp/Meschach.h + - configure.in: remove check for HUGE_VAL + (as this was a temporary problem of intermediate Cygwin 1.1) + +11/29/00: rf: remove newly defined types from Hqp_Docp C calling interface + (use same types as in Hqp implementation, i.e. Real, VECP, ... + instead of Float, FloatVec, ... + reserve the new names for a possible future component interface) + - remove iftcl/If_types.h + - modify iftcl/If.[hC], hqp/Hqp.[hC], omu/Hqp_Docp_stub.[hC], + hqp_docp/Docp_Main.C, hqp_docp/Prg_Di.[hC] + +11/25/00: rf + - hqp/sprcm.C: bug fix in function sp_rcm_scan + - hqp/Hqp_Docp.C: modified problem setup for correct hot start + - hqp_docp/Prg_Di.C, hqp_docp/Docp_Main.C: new theHqp_Docp_handle + - hqp/Hqp.[hC] corrections for new data types + +11/23/00: rf: improved error handling + - hqp/Meschach.h: introduce macro "catcherr" using Meschach's catch + - hqp/Hqp_IpsFranke.C, hqp/Hqp_IpsMehrotra.C: use catcherr + to detect degeneration, instead of direct access to setjmp() + - omu/Hqp_Omuses.C: apply Meschach's "catchall" to integrator->solve, + so that integration errors result in SQP step shortening + +11/22/00: rf + - omu/Omu_Init.C, omu/Makefile: add Omu_IntSDIRK + (provided by H. Linke) + - hqp/Hqp_Docp.C: break updating stages when _f becomes infinite + +11/20/00: rf + - omu/Hqp_Omuses.[hC]: implemet setup_struct() and call + obtain_structure from there (instead from setup_vars) + - hqp/Hqp_Docp.C: call setup_horizon() from general setup() + (instead from setup_x) + +11/15/00: rf + - hqp/Hqp_SqpSolver::feasible_vals: + introduce check for is_finite(_prg->f()) + - iftcl/If.[hC]: introduce If_SizeOfInt() and If_SizeOfFloat() + (as proposed by Christian Schulz) + +11/09/00: rf: introduced C calling interface to iftcl + - change version to 1.7a2 + - mv iftcl/If.h to iftcl/If_id.h + - new file iftcl/If.h for public declarations, + iftcl/If.C for implementation, iftcl/If_types.h for types + - Hqp.C: Hqp_Docp_create initializes Tcl internally, + if this has not been done by calling program + - ./configure.in: slight modification for building a DLL + - hqp_docp: demo new features in Docp_Main.C + +11/07/00: rf: improved generation of Hqp shared object + - change version to 1.7a1 + - Hqp.[hC]: provide new Hqp Docp interface + that hides implementation details + (i.e. no C++ inheritance from implementation in hqp/Hqp_Docp) + - adapt hqp_docp to demonstrate new interface + - new file hqp/Hqp_Docp_wrapper.h to connect interface to Hqp_Docp + - new files omu/Hqp_Docp_stub.[hC] to mimic Hqp_Docp for Omuses + - omu/Hqp_Omuses is now derived from omu/Hqp_Docp_stub + - extensions to configure.in for generation of hqp.dll using cl + +11/03/00: rf: add support for cl compiler + - hqp/Hqp_IpSpSC.C: correct prototype for spCHOLsol() + - hqp/meschext_ea.h: remove argument lists after #undef's + - new file makedirs (former directories part of makedefs) + that is also included by hqp_docp/Makefile and odc/Makefile + (as automatically configured paths need to be customized for cl) + - extensions in configure.in, makedefs.in, and Makefiles + - hqp/Meschach.h: additionally include math.h before matrix.h for cl + +11/03/00: rf: + - hqp/Meschach.h: add std C++ methods "size" to VECP, MATP and IVECP + - separate hqp/Hqp.h into hqp/Hqp.h (external visible declarations) + and hqp/Hqp_impl.h (further declarations for HQP implementation) + - former Hqp.C becomes Hqp_impl.C + +11/01/00: rf: + - bug fix in meschach/hessen.c after call to hhvec in hsehldr.c + to avoid infinite loop in symmeig() + - hqp/Hqp_HL_BFGS.C: change default _eigen_control to true + - omu/Omu_IntDASPK.C (realloc): more sensible allocation of memory + when using direct solver + +08/02/00: rf: + - change version to 1.6.1 + - omu/Omu_IntDASPK.C: add _nsteps (prg_int_nsteps) for + user-defined number of integrator steps + +06/06/00: release HQP 1.6 + +06/05/00: rf: + - omu/Omu_IntDASPK.C changed defaults for _krylov_prec + to false; + changed _krylov and staggert mode back to their original + values, false and true, respectively!? + +05/30/00: ea: + - omu/Omu_IntIMP.[hC] added + implicit midpoint rule for stiff ODEs + +05/22/00: rf: + - omu/Omu_Init.C: correct include Omu_IntOdeTS.h to Omu_IntOdeTs.h + as reported by H. Mittelmann + +05/18/00: release HQP 1.6b2 + +05/17/00: rf: + - omu/Omu_Vector.C: add explicit call to constructor of VECP from + copy constructor of Omu_Vector + - omu/Hqp_Omuses.C: add check that vector dimension is not changed + in Omu_Program::init_simultion + +05/13/00: rf: + - omu/Omu_Program.[hC]: add high-level contsistic + +05/13/00: rf: + - omu/Hqp_Omuses.C, omu/Omu_IntDASPK.C, omu/Omu_IntODE.[hC]: + add support for _nv>0 expansion variables, i.e. sensitivities + are only calculated with respect to _nx states used by optimization + - omu/Omu_Integrator.[hC]: + new member _nx for number of states used as optimization variables + - omu/Omu_IntDASPK.C: don't provide analytical Jacobian to DASPK, + if it is not explicitly given via low level continuous + +04/29/00: rf: + - extend omu/Omu_IntDASPK.[hC] with iterative Krylov capabilities + as worked out by hl + - omu/Omu_Integrator: introduce new flag _serr (prg_int_serr) + for user coice if sensitivities should be considered in error test + (default: false) + - omu/Omu_IntRKsuite, omu/Omu_IntDASPK: add support for _serr + - omu/Hqp_Omuses::obtain_struct: + exclude discrete states from determination of semi-bandwidths + - hqp/Hqp_Docp.[hC], omu/Hqp_Omuses.[hC]: + remove method reinit_bounds() and call init_vars() directly + from Hqp_Docp::reinit_bd + - hqp/Hqp_SqpSolver.C: take out update of Jacobians if hot started + +04/14/00: release HQP 1.6b1 + +04/09/00: rf: integrate DASPK3.0 with Omuses + - add files omu/Omu_IntDASPK.[hC] + - omu/Omu_Integrator.[hC]: remove dimensions from init_sample() + as they are constant within one stage; + pass xk and uk to init_stage() instead. + omu/Hqp_Omuses.C: change calls appropriately + - omu/Hqp_Omuses.C, omu/Omu_Vars.[hC]: introduce flag D_is_const + to indicate explicit differential equations + - omu/Omu_Integrator.[hC]: introduce new variables + _n (number of continuous states) and _m (number of parameters) + - omu/Omu_Integrator.[hC]: introduce general _res_evals, + _sen_evals, and _jac_evals; + update other integrators appropreately + - omu/Omu_Program.C: bug fix in ll. continuous for DAE integrators + +04/07/00: rf + - omu/Omu_Integrator.C: change default _rtol from 1e-6 to 1e-8 + +04/06/00: rf: add hot start feature to Sqp solver: + - hqp/Hqp_SqpSolver.[hC]: new method qp_reinit_bd + (Tcl command sqp_qp_reinit_bd), + which causes a re-initialization of bounds + - hqp/Hqp_SqpProgram.[hC]: add callback method reinit_bd + (provide default that does nothing) + - hqp/Hqp_Docp.[hC]: implement reinit_bd, provide new + interface method reinit_bounds(k, ...) + - omu/Hqp_Omuses.[hC]: implement reinit_bounds + (for now just call Omu_Program::setup assuming that no dims change) + +04/03/00: rf + - add low-level continuous to omu/Omu_Program, + which calculates Jacobians using ADOL-C by default + --> can be overridden to provide analytic Jacobians + - let omu/Omu_IntODE call low-level continuous + - change default omu/Omu_Integrator::_atol from 1e-12 to 1e-8 + - omu/Hqp_Omuses.C: use Dopri5 as default integrator + +03/30/00: ea + - move _rtol, _atol, prg_int_atol, prg_int_rtol to Omu_Integrator.[hC] + - update Omu_IntDopri5.[hC] + +03/29/00: ea + - initialize CVS repository with version 1.6a4 + +03/29/00: rf + - make ADOL-C working with Cygwin + (mv adol-c/SRC/{adallocc,taputilc,tayutilc}.c to + adol-c/SRC/{adalloc,taputil,tayutil}.c and + adol-c/SRC/DRIVERS/{driversc,odedriversc}.c to + adol-c/SRC/DRIVERS/{drivers,odedrivers}.c and + adol-c/SRC/SPARSE/{sparsec}.c to + adol-c/SRC/SPARSE/{sparse}.c) + - configure.in: temporarily disabled check for g2c.h and f2c.h + (due to name clash with ADOL-C 1.8.7 SRC/DRIVERS/taylor.h) + +03/27/00: hl, ea + - update to ADOL-C 1.8.7 + +------------------------------------------------------------------------------- +11/10/99: ea + - Omu_IntRK4.[hC]: prg_int_atol, prg_int_rtol (dummy) + +08/20/99: ea + - bugfix in Hqp_IpLQDOCP.C + +05/07/99: ea + - update Omu_IntOdeTS.[Ch] + +04/27/99: ea + - update to ADOL-C 1.8.2 + - change configure.in for egcs-1.1.2 (g77, libg2c) + - add omu/Omu_IntDopri5.[hC]: Dormand-Prince method +------------------------------------------------------------------------------- +03/22/00: rf + - include Omuses, Odc, and ADOL-C with distribution + - omu/Omu_Init.C: add call to Tcl_PkgRequire/Provide + - meschach/{machine, matrix, sparse}.h: replace __*_DECLS with MESCH__*_DECLS + - remove +#ifdef HAVE_IEEEFP_H +#include +#endif + from hqp/Hqp_{Docp, DocpAdol, IpsFranke, IpsMehrotra, SqpPowell, SqpSchittkowski}.C as finite() is no longer called. + - remove check for ieeefp.h from configure.in and makedefs.in + - configure.in, omu/Omu_IntRKsuite.C: + add explicit support for g77, g2c.h, and -lg2c (avoid links) + +01/06/00: rf + - modify configure script (consider TEA, run non-interactive) + - define VERSION in configure.in instead of in hqp/Hqp_Init.C + - let U_INT_DEF in meschach/machine.h be determined with configure + +01/06/00: rf + - move defininition of const int Hqp_Docp::Periodical from .h to .C + - define own is_finite in Hqp.h (to get rid of BSD finite) + - exchange use of finite with is_finite + - remove (void) arg form t_mesch.[hC] and default args from t_mesch.C + - remove qsort.c from HQP sources (in hqp/Makefile) + +12/25/99: rf + - hqp/Hqp_Init.C: add call to Tcl_PkgRequire + - hqp/Hqp_Init.C: remove utime implementation + +12/23/99: rf + - change sign in Hqp_SqpProgram::test_cmd, so that it can + be used to approximate gradients numerically + - extended member access methods for Hqp_SqpSolver + - hqp_solve.tcl: print header line only if sqp_iter == 0 + - hqp/Meschach.[hC]: sp_update_val returns int != 0 if new entry + created + - hqp/Prg_CUTE*.C use sp_update_val instead of own sp_set_val2 + - move sprow_zero from Prg_CUTE*.C to Meschach.[hC] + +12/21/99: rf + Resolve name clashes with ASCEND + - meschach/matrix.h L480: take away declaration of cube + - meschach/norm.c L68ff: take away definition of cube + - meschach/bkpfacto.c L45: make sqr static + +12/21/99: rf + - rename hqp/Hqp_CUTEstubs1.C to hqp/Hqp_CUTE_stubs_.C + - rename hqp/Hqp_CUTEstubs2.C to hqp/Hqp_CUTE_dummies.C + +12/17/99: rf + - add files hqp/Prg_ASCEND.[hC], hqp/Hqp_ASCEND_dummies.C + +12/16/99: rf + - rename __P to MESCH__P in meschach/{machine,matrix,sparse}.h + as gcc version egcs-2.91.66 defines __P with throw() + +4/13/99: release HQP 1.5p1 +4/13/99: rf + - rename hqp/hqp.tcl to hqp/hqp_solve.tcl to avoid name conflict + with hqp/Hqp.C on systems that don't distinguish lower and upper case + - update hqp/Hqp_Init.C to evaluate hqp_solve + - update hqp/Makefile to build hqp_solve + - change eigen_control default to false, + (because Meschach's symmeig() may have endless iteration) + + diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..4ef37ff --- /dev/null +++ b/Makefile @@ -0,0 +1,48 @@ +include makedefs + +all: + $(MAKE) -f Makefile.hqp + if test ! "$(CXX)" = "cl -nologo"; then $(MAKE) omuses; fi + +omuses: + cd adol-c/INS; $(MAKE) xxxinstall; cd ../.. + cd adol-c/SRC; $(MAKE); cd ../.. + cd omu; $(MAKE); cd .. + mv omu/$(LIB_PREFIX)omu$(LIB_SUFFIX) lib + cd odc; $(MAKE); ./run Crane; cd .. + +clean: + cd odc; $(MAKE) clean; cd .. + cd malloc; $(MAKE) clean; cd .. + cd rksuite; rm -f *.o *~; cd .. + cd daspk; rm -f */*.o */*/*.o */*~ */*/*~ \ + examples/DM/heat examples/DM/heat.exe \ + examples/DM/heatilu examples/DM/heatilu.exe; cd .. + cd omu; $(MAKE) clean; cd .. + cd adol-c/SRC; $(MAKE) cleanall; rm -f makefile; cd ../.. + $(MAKE) -f Makefile.hqp clean + cd hqp_docp; $(MAKE) clean; cd .. + rm -f hqp_cute/*~ + +distclean: clean + rm -f makedefs makedirs odc/Makefile hqp_docp/Makefile + +LIB_DIR = $(INSTALL_PREFIX)/lib +INC_DIR_ROOT = $(INSTALL_PREFIX)/include +INC_DIR = $(INC_DIR_ROOT)/omuses +install: + @if test ! -d $(LIB_DIR); then mkdirhier $(LIB_DIR); fi + $(INSTALL) lib/libhqp$(LIB_SUFFIX) lib/libomu$(LIB_SUFFIX) $(LIB_DIR) + @if test ! -d $(INC_DIR_ROOT); then mkdir $(INC_DIR_ROOT); fi + @if test ! -d $(INC_DIR); then mkdir $(INC_DIR); fi + for f in meschach/*.h iftcl/*.h hqp/*.h adol-c/SRC/*.h omu/*.h; do \ + $(INSTALL_DATA) $$f $(INC_DIR); done + @if test ! -d $(INC_DIR)/DRIVERS; then mkdir $(INC_DIR)/DRIVERS; fi + for f in adol-c/SRC/DRIVERS/*.h; do \ + $(INSTALL_DATA) $$f $(INC_DIR)/DRIVERS; done + @if test ! -d $(INC_DIR)/SPARSE; then mkdir $(INC_DIR)/SPARSE; fi + for f in adol-c/SRC/SPARSE/*.h; do \ + $(INSTALL_DATA) $$f $(INC_DIR)/SPARSE; done + @if test ! -d $(INC_DIR)/TAPEDOC; then mkdir $(INC_DIR)/TAPEDOC; fi + for f in adol-c/SRC/TAPEDOC/*.h; do \ + $(INSTALL_DATA) $$f $(INC_DIR)/TAPEDOC; done diff --git a/Makefile.hqp b/Makefile.hqp new file mode 100644 index 0000000..0561223 --- /dev/null +++ b/Makefile.hqp @@ -0,0 +1,33 @@ + +include makedefs + +all: + cd meschach; $(MAKE); cd .. + cd iftcl; $(MAKE); cd .. + cd hqp; $(MAKE); cd .. + mv hqp/$(LIB_PREFIX)hqp.* lib + if test -f lib/hqp.dll; then cp lib/*.dll hqp_docp; fi + cd hqp_docp; $(MAKE); ./docp; cd .. + +clean: + cd hqp_docp; $(MAKE) clean; cd .. + rm -f hqp_docp/*.dll + cd malloc; $(MAKE) clean; cd .. + cd hqp; $(MAKE) clean; cd .. + cd iftcl; $(MAKE) clean; cd .. + rm -f meschach/*.o meschach/*.obj meschach/*~ + rm -f lib/*.* config.* *~ + +distclean: clean + rm -f makedefs makedirs hqp_docp/Makefile + +LIB_DIR = $(INSTALL_PREFIX)/lib +INC_DIR_ROOT = $(INSTALL_PREFIX)/include +INC_DIR = $(INC_DIR_ROOT)/hqp +install: + @if test ! -d $(LIB_DIR); then mkdir $(LIB_DIR); fi + $(INSTALL) lib/libhqp$(LD_SUFFIX) $(LIB_DIR) + @if test ! -d $(INC_DIR_ROOT); then mkdir $(INC_DIR_ROOT); fi + @if test ! -d $(INC_DIR); then mkdir $(INC_DIR); fi + for f in meschach/*.h iftcl/*.h hqp/*.h; do \ + $(INSTALL_DATA) $$f $(INC_DIR); done diff --git a/README b/README new file mode 100644 index 0000000..4d7cb92 --- /dev/null +++ b/README @@ -0,0 +1,150 @@ + +README for HQP/Omuses 1.7 +-- This software is free according to the conditions of the + GNU LIBRARY GENERAL PUBLIC LICENSE, Version 2 (see COPYING.LIB) -- +Ruediger Franke, 11/01/00 + +HQP is a solver for nonlinearly constrained large-scale optimization +problems. It is developed with respect to problems that have a +sufficient regular sparsity structure, e.g. discrete-time optimal +control problems. Its key features are: + + implementation with algorithms and data structures for sparse matrices + + interior point procedure for the treatment of constraints + + Newton-type SQP procedure for the treatment of nonlinearities + +Omuses is a front-end for HQP. It supports the efficient formulation +and solution of multistage problems (e.g. discrete-time optimal control +problems). Its key features are: + + optimization problems are specified in the programming + language C++ + + ADOL-C is used for the automatic calculation of exact derivatives and + sensitivity equations + + numerical integration routines are provided for the treatment of + differential equations + + HQP is applied to the solution of the internally formed large-scale + nonlinear programming problems + +Following contributions with partly different copyrights are included: +meschach -- matrix library by D.E. Steward and Z. Leyk +adol-c -- automatic differentiation by A. Griewank et al +hqp/Mehrotra -- Mehrotra's interior point algorithm implemented by E. Arnold +hqp/LQDOCP -- block-oriented matrix solver by E. Arnold +hqp/SpSC -- sparse Schur complement matrix solver by H. Linke +rksuite -- ODE integration by R.W. Brankin et al +daspk -- DAE integration by L. Petzold et al +omu/SDIRK -- DAE integration using implicit midpoint rule by E. Arnold +omu/IMP -- ODE integration using implicit ADOL-C by H. Linke +omu/OdeTs -- ODE integration using ADOL-C by H. Linke +hqp/qsort -- quick sort routine from NetBSD +gmalloc -- GNU malloc routines + +The software can be installed as follows (basically two libraries, +libhqp and libomu, as well as a demo collection in ./odc are built). + +0) +You need to have Tcl version 8.0 (or higher) and a C++ compiler; +gcc is assumed per default (see below for using an other compiler). + +1) +Unpack the distribution file by invoking + tar -xzf hqp.tar.gz +This creates a new directory hqp containing everything. + +2) +cd to the created directory and invoke + ./configure +to create the files ./makedirs, ./makedefs + ./odc/Makefile, and ./hqp_docp/Makefile. +Following options can be specified: + --prefix=PATH + Path where you'd like to install the libraries and include files + (default is /usr/local). +Build options: + --enable-fortran + Include the numerical integration routines DASPK and RKsuite with + libomu. This requires an f77 compiler on your machine. The automatic + settings done by ./configure are only guesses. + Please check the variables FORTRAN_* in ./makedefs manually. + --enable-gmalloc + Use GNU malloc instead of the system routines. Gmalloc will be enabled + automatically if your system malloc doesn't work properly (e.g. under + DEC OSF). According to the authors experience gmalloc doesn't work on + all machines, but fortunately it does where it's needed :-) + --enable-cute + Include CUTE interface with HQP. + --enable-ascend + Include current preliminary version of an interface to Ascend4. + This requires that this distribution is unpacked in the directory of + the Ascend distribution, e.g. in /home/myname/ascendiv-0.9 + (for Ascend see http://www.cs.cmu.edu/~ascend/Home.html) +Use a specific Tcl installation, which is not found automatically: + --with-tcl + Directory containing Tcl configuration file tclConfig.sh, e.g. + --with-tcl=/cygnus/cygwin-b20/H-i586-cygwin32/lib + --with-tclinclude + Directory containing include file tcl.h. + +3) +Compile the distribution by invoking + make +(or + make -f Makefile.hqp + to avoid building ADOL-C, Omuses, and Odc) + +4) +Directly after compilation, a test run of an example in ./odc is performed +automatically that should produce the result "optimal". Some more examples +are given in ./odc (please see the documentation in ./doc). + +5) +Install the libraries and includes if you want by invoking + make install +The following files are created: + + $prefix / lib / libhqp.so + / libomu.so + / include / omuses / *.h + +6) +See ./hqp_docp/README if you want to apply HQP directly to multistage +problems without using ADOL-C and differential equations. + +7) +See ./hqp_cute/README if you want to use HQP in the testing environment +CUTE. + +8) +Send correspondence to: hqp@rz.tu-ilmenau.de + +Use an other compiler than gcc +============================== +for using an other compiler, say cl, invoke + CC=cl ./configure + +Hints for using cl, i.e. the "native" compiler under Windows: + - you need Cygwin (see http://sources.redhat.com) + in order to run the automatic configuration and make + (Note that Cygwin 1.1 is not considered stable, b20 works fine!) + - the location of cl must be in your PATH environment + - the automatically generated file makedirs + needs to be customized manually with drive names for absolute paths + (e.g. insead of "/Programs/Tcl/lib" write "c:/Programs/Tcl/lib" + - cl does work for HQP, but not for ADOL-C used in the front-end Omuses + You can use cl to greate a DLL for HQP and compile Omuses with gcc. + +Alternative for Windows: + - compile everything under Cygwin + - Cygwin version b20(.1) was tested successfully. It can be extended + with EGCS-1.1 F77 to enable Fortran modules. + +Known Problems +============== +1) problems with specific gcc versions: +- gcc 2.95* produces many warnings on standard C++ code + (please use a version between 2.8.1 and 2.91*, or wait for 2.96) +- gcc 2.8.0 and egcs 1.0.3 can't compile a method "resize" + (tested and rejected by automatic configuration) +- gcc 2.7 does not work under DEC OSF with code optimization + (Please edit the automatically generated file makedefs. + The optimization is not disabled automatically as the generated + code will be rather slow) diff --git a/adol-c/INS/README.INS b/adol-c/INS/README.INS new file mode 100644 index 0000000..9305dd4 --- /dev/null +++ b/adol-c/INS/README.INS @@ -0,0 +1,77 @@ +-------------------------------------------------------------- +README.INS ADOL-C version 1.8.7 as of MAR/10/2000 +-------------------------------------------------------------- + +This directory, i.e. $(ADOLC_DIR)/INS, contains the component +files necessary to generate all makefiles. + +-------------------------------------------------------------- +INSTALLATION OF MAKEFILES + +Invoking the commmand + + make install + +creates all makefiles necessary to compile + + - the ADOL-C library libad.a in directory $(ADOLC_DIR)/SRC), + - the documented examples in directory $(ADOLC_DIR)/DEX, and + - the examples in directory $(ADOLC_DIR)/EXA. + +-------------------------------------------------------------- +OPERATING SYSTEM + + may take one of the following values + + sun --> Sun Microsystems Inc., + tested on: SunOS 5.5.1 + using: SC4.0 18 Oct 1995 C 4.0 & C++ 4.1 + + aix --> IBM + tested on: AIX Version 3.2.5e4 + using: xlc & xlC + + gnu --> Any system using GNU C/C++ + tested on: LinuX (Kernel 2.0.35) + using: gcc version 2.7.2.3 + tested on: CRAY Origin 2000 (MIPS RISC R10000) + IRIX Release 6.5 IP27 + using: gcc version 2.8.1 + tested on: SunOS 5.7 (Solaris) + using: gcc version egcs 2.91.66 (19990314) + tested on: DEC Alpha (OSF 1) + using: gcc version 2.95.2 (19991024) + + DEC --> DEC + tested on: DEC Alpha Digital Unix V4.0B (Rev. 564) + using: DEC's cxx & cc + + sgi --> Silicon Graphics + tested on: CRAY Origin 2000 (MIPS RISC R10000) + IRIX Release 6.5 IP27 + using: MIPSpro Compilers: Version 7.2.1 + + xxx --> for OWN needs + +The provided files + + _comp + +contain all compiler configurations. If necessary, edit the file +corresponding to the desired operating system and choose/set +appropriate compiler options (e.g. optimization flags). Possibly +change the C/C++ compilers. + +-------------------------------------------------------------- +CLEANUP + +Invoking the command + + make uninstall + +cleans up all ADOL-C directories. + +-------------------------------------------------------------- + + + diff --git a/adol-c/INS/aix_comp b/adol-c/INS/aix_comp new file mode 100644 index 0000000..52dcc1c --- /dev/null +++ b/adol-c/INS/aix_comp @@ -0,0 +1,35 @@ +#************************************************************************** +# Which compilers do you use? COMPILER * +CC = xlC # C++ +MCC = xlc -qcpluscmt # C + + +#************************************************************************** +# COMPILER FLAGS * +# GENERAL FLAGS (e. g. optimization) +#CFLAG = -g +#CFLAG = +#CFLAG = -O +CFLAG = -O2 + +# INCLUDES +IFLAG = -I$(ADHEADERS) + +# LIBRARIES (COMPILING) +LFLAG = -L$(ADLIB) + +# LIBRARIES (LINKING) +LIBS = -lad -lm + +# PREPROCESSOR FLAGS +PPFLAGS = -E -C + + +#************************************************************************** +# ar/ranlib utility LIBRARY TOOLS * +ARCHIVE = ar rcv +RANLIB = ar qs +# RANLIB =`if [ -r /bin/ranlib -o -r /usr/bin/ranlib ]; \ +# then echo ranlib; else echo true; fi` + + diff --git a/adol-c/INS/dec_comp b/adol-c/INS/dec_comp new file mode 100644 index 0000000..79f47cd --- /dev/null +++ b/adol-c/INS/dec_comp @@ -0,0 +1,44 @@ +#************************************************************************** +# Which compilers do you use? COMPILER * +CC = cxx # C++ +MCC = cc # C + + +#************************************************************************** +# COMPILER FLAGS * +# GENERAL FLAGS (e. g. optimization) +#CFLAG = -g +#CFLAG = +CFLAG = -O2 +#CFLAG = -O3 + +# INCLUDES +IFLAG = -I$(ADHEADERS) + +# LIBRARIES (COMPILING) +LFLAG = -L$(ADLIB) + +# LIBRARIES (LINKING) +LIBS = -lad -lm + +# PREPROCESSOR FLAGS +PPFLAGS = -E -C + + +#************************************************************************** +# ar/ranlib utility LIBRARY TOOLS * +ARCHIVE = ar rcv +RANLIB = ar qs +# RANLIB =`if [ -r /bin/ranlib -o -r /usr/bin/ranlib ]; \ +# then echo ranlib; else echo true; fi` + + + + + + + + + + + diff --git a/adol-c/INS/gnu_comp b/adol-c/INS/gnu_comp new file mode 100644 index 0000000..5ec4d47 --- /dev/null +++ b/adol-c/INS/gnu_comp @@ -0,0 +1,34 @@ +#************************************************************************** +# Which compilers do you use? COMPILER * +CC = g++ # C++ +MCC = gcc # C + + +#************************************************************************** +# COMPILER FLAGS * +# GENERAL FLAGS (e. g. optimization) +#CFLAG = -g +#CFLAG = +#CFLAG = -O +CFLAG = -O2 + +# INCLUDES +IFLAG = -I$(ADHEADERS) # uncomment if necessary -I/usr/lib/g++-include + +# LIBRARIES (COMPILING) +LFLAG = -L$(ADLIB) + +# LIBRARIES (LINKING) +LIBS = -lad -lm + +# PREPROCESSOR FLAGS +PPFLAGS = -trigraphs -E -C + + +#************************************************************************** +# ar/ranlib utility LIBRARY TOOLS * +ARCHIVE = ar rcv +RANLIB = ar qs +# RANLIB =`if [ -r /bin/ranlib -o -r /usr/bin/ranlib ]; \ +# then echo ranlib; else echo true; fi` + diff --git a/adol-c/INS/makefile b/adol-c/INS/makefile new file mode 100644 index 0000000..8ba0c96 --- /dev/null +++ b/adol-c/INS/makefile @@ -0,0 +1,56 @@ +#************************************************************************** +# +# -------------------------------------------------------------- +# makefile (INS) of ADOL-C version 1.8.7 as of Mar/10/2000 +# -------------------------------------------------------------- +# makefile for generating all other makefiles and total clean up +# +#************************************************************************** + +COMPONENTS = makefile.SRC.head makefile.SRC.tail + + +gnuinstall: $(COMPONENTS) gnu_comp + cat makefile.SRC.head gnu_comp makefile.SRC.tail > ../SRC/makefile + @echo installation of makefiles finished + + +aixinstall: $(COMPONENTS) aix_comp + cat makefile.SRC.head aix_comp makefile.SRC.tail > ../SRC/makefile + @echo installation of makefiles finished + + +suninstall: $(COMPONENTS) sun_comp + cat makefile.SRC.head sun_comp makefile.SRC.tail > ../SRC/makefile + @echo installation of makefiles finished + + +decinstall: $(COMPONENTS) dec_comp + cat makefile.SRC.head dec_comp makefile.SRC.tail > ../SRC/makefile + @echo installation of makefiles finished + + +sgiinstall: $(COMPONENTS) sgi_comp + cat makefile.SRC.head sgi_comp makefile.SRC.tail > ../SRC/makefile + @echo installation of makefiles finished + + +xxxinstall: $(COMPONENTS) xxx_comp + cat makefile.SRC.head xxx_comp makefile.SRC.tail > ../SRC/makefile + @echo installation of makefiles finished + + +uninstall: + ( cd ../SRC; make cleanall) + -rm ../SRC/makefile + -rm *~ + @echo uninstallation finished + + + + + + + + + diff --git a/adol-c/INS/makefile.SRC.head b/adol-c/INS/makefile.SRC.head new file mode 100644 index 0000000..3b17cac --- /dev/null +++ b/adol-c/INS/makefile.SRC.head @@ -0,0 +1,35 @@ +#************************************************************************** +# +# -------------------------------------------------------------- +# makefile (SRC) of ADOL-C version 1.8.0 as of Nov/30/98 +# -------------------------------------------------------------- +# makefile for the library libad.a of ADOL-C +# +#************************************************************************** + + +#************************************************************************** +# Path to drivers DRIVERS * +ADDRIVERS = ./DRIVERS + + +#************************************************************************** +# Path to sparsity exploring and exploating utilities SPARSE * +ADSPARSE = ./SPARSE + + +#************************************************************************** +# Path to Tape Documentation Utility TAPEDOC * +ADTAPEDOC = ./TAPEDOC + + +#************************************************************************** +# Path to AD-library libad.a ADLIB * +ADLIB = . + + +#************************************************************************** +# Path to AD-headers adouble.h, avector.h, ... ADHEADERS * +ADHEADERS = . + + diff --git a/adol-c/INS/makefile.SRC.tail b/adol-c/INS/makefile.SRC.tail new file mode 100644 index 0000000..4ec2073 --- /dev/null +++ b/adol-c/INS/makefile.SRC.tail @@ -0,0 +1,321 @@ +#************************************************************************** +# THE ADOL-C LIBRARY (libad) * +libad: adouble.o avector.o taputil.o taputilC.o \ + hos_forward.o fos_forward.o zos_forward.o hov_forward.o \ + fov_forward.o hos_reverse.o fos_reverse.o hov_reverse.o \ + fov_reverse.o convolut.o fortutils.o tayutil.o tayutilC.o \ + interfacesC.o interfacesf.o\ + $(ADDRIVERS)/drivers.o $(ADDRIVERS)/driversf.o \ + $(ADDRIVERS)/odedriversC.o $(ADDRIVERS)/odedrivers.o \ + $(ADDRIVERS)/odedriversf.o $(ADDRIVERS)/taylor.o \ + $(ADSPARSE)/int_forward_t.o $(ADSPARSE)/int_forward_s.o \ + $(ADSPARSE)/int_reverse_t.o $(ADSPARSE)/int_reverse_s.o \ + $(ADSPARSE)/jacutils.o $(ADSPARSE)/sparse.o \ + $(ADSPARSE)/sparseC.o $(ADTAPEDOC)/tapedoc.o \ + adalloc.o adallocC.o + $(RANLIB) libad.a + @echo 'Library created' + + +#************************************************************************** +# INTERFACES * + +#-------------------------------------------------------------------------- +# C++ - +interfacesC.o: interfacesC.C dvlparms.h usrparms.h interfaces.h adalloc.h + $(CC) -c $(CFLAG) $(IFLAG) interfacesC.C + $(ARCHIVE) libad.a interfacesC.o + +#-------------------------------------------------------------------------- +# Fortran callabel C - +interfacesf.o: interfacesf.c dvlparms.h usrparms.h interfaces.h \ + adalloc.h fortutils.h + $(MCC) -c $(CFLAG) $(IFLAG) interfacesf.c + $(ARCHIVE) libad.a interfacesf.o + + +#************************************************************************** +# DRIVERS * + +#-------------------------------------------------------------------------- +# OPTIMIZATION - +$(ADDRIVERS)/drivers.o: $(ADDRIVERS)/drivers.c dvlparms.h adalloc.h \ + $(ADDRIVERS)/drivers.h interfaces.h usrparms.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADDRIVERS)/drivers.o \ + $(ADDRIVERS)/drivers.c + $(ARCHIVE) libad.a $(ADDRIVERS)/drivers.o + +$(ADDRIVERS)/driversf.o: $(ADDRIVERS)/driversf.c dvlparms.h adalloc.h \ + $(ADDRIVERS)/drivers.h interfaces.h usrparms.h \ + fortutils.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADDRIVERS)/driversf.o \ + $(ADDRIVERS)/driversf.c + $(ARCHIVE) libad.a $(ADDRIVERS)/driversf.o + +#-------------------------------------------------------------------------- +# ODE - +$(ADDRIVERS)/odedriversC.o: $(ADDRIVERS)/odedriversC.C dvlparms.h \ + $(ADDRIVERS)/odedrivers.h usrparms.h + $(CC) -c $(CFLAG) $(IFLAG) -o $(ADDRIVERS)/odedriversC.o \ + $(ADDRIVERS)/odedriversC.C + $(ARCHIVE) libad.a $(ADDRIVERS)/odedriversC.o + +$(ADDRIVERS)/odedrivers.o: $(ADDRIVERS)/odedrivers.c dvlparms.h \ + $(ADDRIVERS)/odedrivers.h interfaces.h \ + usrparms.h adalloc.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADDRIVERS)/odedrivers.o \ + $(ADDRIVERS)/odedrivers.c + $(ARCHIVE) libad.a $(ADDRIVERS)/odedrivers.o + +$(ADDRIVERS)/odedriversf.o: $(ADDRIVERS)/odedriversf.c dvlparms.h \ + $(ADDRIVERS)/odedrivers.h interfaces.h \ + usrparms.h adalloc.h fortutils.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADDRIVERS)/odedriversf.o \ + $(ADDRIVERS)/odedriversf.c + $(ARCHIVE) libad.a $(ADDRIVERS)/odedriversf.o + +#-------------------------------------------------------------------------- +# TAYLOR - +$(ADDRIVERS)/taylor.o: $(ADDRIVERS)/taylor.c dvlparms.h usrparms.h \ + $(ADDRIVERS)/taylor.h adalloc.h interfaces.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADDRIVERS)/taylor.o \ + $(ADDRIVERS)/taylor.c + $(ARCHIVE) libad.a $(ADDRIVERS)/taylor.o + + +#************************************************************************** +# NEW CLASSES - OVERLOADING * + +#-------------------------------------------------------------------------- +# ADOUBLE - +adouble.o: adouble.C adouble.h avector.h oplate.h taputil.h \ + tayutil.h dvlparms.h usrparms.h + $(CC) -c $(CFLAG) $(IFLAG) adouble.C + $(ARCHIVE) libad.a adouble.o + +#-------------------------------------------------------------------------- +# AVECTOR / AMATRIX - +avector.o: avector.C adouble.h avector.h oplate.h taputil.h \ + tayutil.h usrparms.h dvlparms.h + $(CC) -c $(CFLAG) $(IFLAG) avector.C + $(ARCHIVE) libad.a avector.o + + +#************************************************************************** +# FORWARD * + +#-------------------------------------------------------------------------- +# HOS - +hos_forward.o: uni5_for.c dvlparms.h taputil.h tayutil.h \ + oplate.h usrparms.h interfaces.h adalloc.h + $(MCC) -c $(CFLAG) $(IFLAG) -o hos_forward.o \ + -D_HOS_ -D_KEEP_ uni5_for.c + $(ARCHIVE) libad.a hos_forward.o + +#-------------------------------------------------------------------------- +# FOS - +fos_forward.o: uni5_for.c dvlparms.h taputil.h tayutil.h \ + oplate.h usrparms.h interfaces.h adalloc.h + $(MCC) -c $(CFLAG) $(IFLAG) -o fos_forward.o \ + -D_FOS_ -D_KEEP_ uni5_for.c + $(ARCHIVE) libad.a fos_forward.o + +#-------------------------------------------------------------------------- +# ZOS - +zos_forward.o: uni5_for.c dvlparms.h taputil.h tayutil.h \ + oplate.h usrparms.h interfaces.h adalloc.h + $(MCC) -c $(CFLAG) $(IFLAG) -o zos_forward.o \ + -D_ZOS_ -D_KEEP_ uni5_for.c + $(ARCHIVE) libad.a zos_forward.o + +#-------------------------------------------------------------------------- +# HOV - +hov_forward.o: uni5_for.c dvlparms.h taputil.h tayutil.h \ + oplate.h usrparms.h interfaces.h adalloc.h + $(MCC) -c $(CFLAG) $(IFLAG) -o hov_forward.o \ + -D_HOV_ uni5_for.c + $(ARCHIVE) libad.a hov_forward.o + +#-------------------------------------------------------------------------- +# FOV - +fov_forward.o: uni5_for.c dvlparms.h taputil.h tayutil.h \ + oplate.h usrparms.h interfaces.h adalloc.h + $(MCC) -c $(CFLAG) $(IFLAG) -o fov_forward.o \ + -D_FOV_ uni5_for.c + $(ARCHIVE) libad.a fov_forward.o + + +#************************************************************************** +# REVERSE * + +#-------------------------------------------------------------------------- +# HOS - +hos_reverse.o: ho_rev.c dvlparms.h taputil.h tayutil.h \ + oplate.h usrparms.h interfaces.h adalloc.h convolut.h + $(MCC) -c $(CFLAG) $(IFLAG) -o hos_reverse.o \ + -D_HOS_ ho_rev.c + $(ARCHIVE) libad.a hos_reverse.o + +#-------------------------------------------------------------------------- +# FOS - +fos_reverse.o: fo_rev.c dvlparms.h taputil.h tayutil.h \ + oplate.h usrparms.h interfaces.h adalloc.h convolut.h + $(MCC) -c $(CFLAG) $(IFLAG) -o fos_reverse.o \ + -D_FOS_ fo_rev.c + $(ARCHIVE) libad.a fos_reverse.o + +#-------------------------------------------------------------------------- +# HOV - +hov_reverse.o: ho_rev.c dvlparms.h taputil.h tayutil.h \ + oplate.h usrparms.h interfaces.h adalloc.h convolut.h + $(MCC) -c $(CFLAG) $(IFLAG) -o hov_reverse.o \ + -D_HOV_ ho_rev.c + $(ARCHIVE) libad.a hov_reverse.o + +#-------------------------------------------------------------------------- +# FOV - +fov_reverse.o: fo_rev.c dvlparms.h taputil.h tayutil.h \ + oplate.h usrparms.h interfaces.h adalloc.h convolut.h + $(MCC) -c $(CFLAG) $(IFLAG) -o fov_reverse.o \ + -D_FOV_ fo_rev.c + $(ARCHIVE) libad.a fov_reverse.o + + +#************************************************************************** +# CONVOLUTION * +convolut.o: convolut.c convolut.h usrparms.h dvlparms.h + $(MCC) -c $(CFLAG) $(IFLAG) convolut.c + $(ARCHIVE) libad.a convolut.o + + +#************************************************************************** +# FORTRAN UTILITIES * +fortutils.o: fortutils.c fortutils.h usrparms.h dvlparms.h + $(MCC) -c $(CFLAG) $(IFLAG) fortutils.c + $(ARCHIVE) libad.a fortutils.o + + +#************************************************************************** +# ADALLOC * +adalloc.o: adalloc.c adalloc.h usrparms.h dvlparms.h + $(MCC) -c $(CFLAG) $(IFLAG) adalloc.c + $(ARCHIVE) libad.a adalloc.o + +adallocC.o: adallocC.C adalloc.h usrparms.h dvlparms.h + $(CC) -c $(CFLAG) $(IFLAG) adallocC.C + $(ARCHIVE) libad.a adallocC.o + + +#************************************************************************** +# ALL UTILITIES * + +#-------------------------------------------------------------------------- +# TAYLOR STUFF (TAYUTILS) - +tayutil.o: tayutil.c dvlparms.h usrparms.h tayutil.h + $(MCC) -c $(CFLAG) $(IFLAG) tayutil.c + $(ARCHIVE) libad.a tayutil.o + +tayutilC.o: tayutilC.C dvlparms.h usrparms.h tayutil.h + $(CC) -c $(CFLAG) $(IFLAG) tayutilC.C + $(ARCHIVE) libad.a tayutilC.o + +#-------------------------------------------------------------------------- +# TAPE STUFF (TAPUTILS) - +taputil.o: taputil.c taputil.h tayutilC.C usrparms.h dvlparms.h oplate.h + $(MCC) -c $(CFLAG) $(IFLAG) taputil.c + $(ARCHIVE) libad.a taputil.o + +taputilC.o: taputilC.C taputil.h usrparms.h dvlparms.h adouble.h + $(CC) -c $(CFLAG) $(IFLAG) taputilC.C + $(ARCHIVE) libad.a taputilC.o + + +#************************************************************************** +# TAPE DOCUMENTATION * +$(ADTAPEDOC)/tapedoc.o: $(ADTAPEDOC)/tapedoc.c $(ADTAPEDOC)/tapedoc.h \ + dvlparms.h taputil.h tayutil.h oplate.h usrparms.h \ + adalloc.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADTAPEDOC)/tapedoc.o \ + $(ADTAPEDOC)/tapedoc.c + $(ARCHIVE) libad.a $(ADTAPEDOC)/tapedoc.o + + +#************************************************************************** +# SPARSE * + +#-------------------------------------------------------------------------- +# INT FORWARD +$(ADSPARSE)/int_forward_t.o: $(ADSPARSE)/int_for.c dvlparms.h taputil.h \ + tayutil.h oplate.h usrparms.h adalloc.h \ + $(ADSPARSE)/jacutils.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADSPARSE)/int_forward_t.o \ + -D_INT_FOR_TIGHT_ $(ADSPARSE)/int_for.c + $(ARCHIVE) libad.a $(ADSPARSE)/int_forward_t.o + +$(ADSPARSE)/int_forward_s.o: $(ADSPARSE)/int_for.c dvlparms.h taputil.h \ + tayutil.h oplate.h usrparms.h adalloc.h \ + $(ADSPARSE)/jacutils.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADSPARSE)/int_forward_s.o \ + -D_INT_FOR_SAFE_ $(ADSPARSE)/int_for.c + $(ARCHIVE) libad.a $(ADSPARSE)/int_forward_s.o + +#-------------------------------------------------------------------------- +# INT REVERSE +$(ADSPARSE)/int_reverse_t.o: $(ADSPARSE)/int_rev.c dvlparms.h taputil.h \ + tayutil.h oplate.h usrparms.h adalloc.h \ + $(ADSPARSE)/jacutils.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADSPARSE)/int_reverse_t.o \ + -D_INT_REV_TIGHT_ $(ADSPARSE)/int_rev.c + $(ARCHIVE) libad.a $(ADSPARSE)/int_reverse_t.o + +$(ADSPARSE)/int_reverse_s.o: $(ADSPARSE)/int_rev.c dvlparms.h taputil.h \ + tayutil.h oplate.h usrparms.h adalloc.h \ + $(ADSPARSE)/jacutils.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADSPARSE)/int_reverse_s.o \ + -D_INT_REV_SAFE_ $(ADSPARSE)/int_rev.c + $(ARCHIVE) libad.a $(ADSPARSE)/int_reverse_s.o + +#-------------------------------------------------------------------------- +# JACOBIAN UTILITIES - +$(ADSPARSE)/jacutils.o: $(ADSPARSE)/jacutils.c dvlparms.h usrparms.h \ + $(ADSPARSE)/jacutils.h adalloc.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADSPARSE)/jacutils.o \ + $(ADSPARSE)/jacutils.c + $(ARCHIVE) libad.a $(ADSPARSE)/jacutils.o + +#-------------------------------------------------------------------------- +# EASY TO USE SPARSE INTERFACE - +$(ADSPARSE)/sparse.o: $(ADSPARSE)/sparse.c dvlparms.h usrparms.h \ + $(ADSPARSE)/jacutils.h $(ADSPARSE)/sparse.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADSPARSE)/sparse.o \ + $(ADSPARSE)/sparse.c + $(ARCHIVE) libad.a $(ADSPARSE)/sparse.o + +$(ADSPARSE)/sparseC.o: $(ADSPARSE)/sparseC.C dvlparms.h usrparms.h \ + $(ADSPARSE)/jacutils.h $(ADSPARSE)/sparse.h + $(CC) -c $(CFLAG) $(IFLAG) -o $(ADSPARSE)/sparseC.o \ + $(ADSPARSE)/sparseC.C + $(ARCHIVE) libad.a $(ADSPARSE)/sparseC.o + + +#************************************************************************** +# CLEAN UP * +clean: + rm -f *.o + rm -f $(ADDRIVERS)/*.o + rm -f $(ADTAPEDOC)/*.o + rm -f $(ADSPARSE)/*.o + @echo clean of directory SRC finished + +cleanall: + rm -f *.o + rm -f $(ADDRIVERS)/*.o + rm -f $(ADTAPEDOC)/*.o + rm -f $(ADSPARSE)/*.o + rm -f libad.a + rm -f *~ + rm -f $(ADDRIVERS)/*~ + rm -f $(ADTAPEDOC)/*~ + rm -f $(ADSPARSE)/*~ + @echo cleanall of directory SRC finished + diff --git a/adol-c/INS/makefile.SRC.tail.ori b/adol-c/INS/makefile.SRC.tail.ori new file mode 100644 index 0000000..927d08a --- /dev/null +++ b/adol-c/INS/makefile.SRC.tail.ori @@ -0,0 +1,321 @@ +#************************************************************************** +# THE ADOL-C LIBRARY (libad) * +libad: adouble.o avector.o taputilc.o taputilC.o \ + hos_forward.o fos_forward.o zos_forward.o hov_forward.o \ + fov_forward.o hos_reverse.o fos_reverse.o hov_reverse.o \ + fov_reverse.o convolut.o fortutils.o tayutilc.o tayutilC.o \ + interfacesC.o interfacesf.o\ + $(ADDRIVERS)/driversc.o $(ADDRIVERS)/driversf.o \ + $(ADDRIVERS)/odedriversC.o $(ADDRIVERS)/odedriversc.o \ + $(ADDRIVERS)/odedriversf.o $(ADDRIVERS)/taylor.o \ + $(ADSPARSE)/int_forward_t.o $(ADSPARSE)/int_forward_s.o \ + $(ADSPARSE)/int_reverse_t.o $(ADSPARSE)/int_reverse_s.o \ + $(ADSPARSE)/jacutils.o $(ADSPARSE)/sparsec.o \ + $(ADSPARSE)/sparseC.o $(ADTAPEDOC)/tapedoc.o \ + adallocc.o adallocC.o + $(RANLIB) libad.a + @echo 'Library created' + + +#************************************************************************** +# INTERFACES * + +#-------------------------------------------------------------------------- +# C++ - +interfacesC.o: interfacesC.C dvlparms.h usrparms.h interfaces.h adalloc.h + $(CC) -c $(CFLAG) $(IFLAG) interfacesC.C + $(ARCHIVE) libad.a interfacesC.o + +#-------------------------------------------------------------------------- +# Fortran callabel C - +interfacesf.o: interfacesf.c dvlparms.h usrparms.h interfaces.h \ + adalloc.h fortutils.h + $(MCC) -c $(CFLAG) $(IFLAG) interfacesf.c + $(ARCHIVE) libad.a interfacesf.o + + +#************************************************************************** +# DRIVERS * + +#-------------------------------------------------------------------------- +# OPTIMIZATION - +$(ADDRIVERS)/driversc.o: $(ADDRIVERS)/driversc.c dvlparms.h adalloc.h \ + $(ADDRIVERS)/drivers.h interfaces.h usrparms.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADDRIVERS)/driversc.o \ + $(ADDRIVERS)/driversc.c + $(ARCHIVE) libad.a $(ADDRIVERS)/driversc.o + +$(ADDRIVERS)/driversf.o: $(ADDRIVERS)/driversf.c dvlparms.h adalloc.h \ + $(ADDRIVERS)/drivers.h interfaces.h usrparms.h \ + fortutils.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADDRIVERS)/driversf.o \ + $(ADDRIVERS)/driversf.c + $(ARCHIVE) libad.a $(ADDRIVERS)/driversf.o + +#-------------------------------------------------------------------------- +# ODE - +$(ADDRIVERS)/odedriversC.o: $(ADDRIVERS)/odedriversC.C dvlparms.h \ + $(ADDRIVERS)/odedrivers.h usrparms.h + $(CC) -c $(CFLAG) $(IFLAG) -o $(ADDRIVERS)/odedriversC.o \ + $(ADDRIVERS)/odedriversC.C + $(ARCHIVE) libad.a $(ADDRIVERS)/odedriversC.o + +$(ADDRIVERS)/odedriversc.o: $(ADDRIVERS)/odedriversc.c dvlparms.h \ + $(ADDRIVERS)/odedrivers.h interfaces.h \ + usrparms.h adalloc.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADDRIVERS)/odedriversc.o \ + $(ADDRIVERS)/odedriversc.c + $(ARCHIVE) libad.a $(ADDRIVERS)/odedriversc.o + +$(ADDRIVERS)/odedriversf.o: $(ADDRIVERS)/odedriversf.c dvlparms.h \ + $(ADDRIVERS)/odedrivers.h interfaces.h \ + usrparms.h adalloc.h fortutils.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADDRIVERS)/odedriversf.o \ + $(ADDRIVERS)/odedriversf.c + $(ARCHIVE) libad.a $(ADDRIVERS)/odedriversf.o + +#-------------------------------------------------------------------------- +# TAYLOR - +$(ADDRIVERS)/taylor.o: $(ADDRIVERS)/taylor.c dvlparms.h usrparms.h \ + $(ADDRIVERS)/taylor.h adalloc.h interfaces.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADDRIVERS)/taylor.o \ + $(ADDRIVERS)/taylor.c + $(ARCHIVE) libad.a $(ADDRIVERS)/taylor.o + + +#************************************************************************** +# NEW CLASSES - OVERLOADING * + +#-------------------------------------------------------------------------- +# ADOUBLE - +adouble.o: adouble.C adouble.h avector.h oplate.h taputil.h \ + tayutil.h dvlparms.h usrparms.h + $(CC) -c $(CFLAG) $(IFLAG) adouble.C + $(ARCHIVE) libad.a adouble.o + +#-------------------------------------------------------------------------- +# AVECTOR / AMATRIX - +avector.o: avector.C adouble.h avector.h oplate.h taputil.h \ + tayutil.h usrparms.h dvlparms.h + $(CC) -c $(CFLAG) $(IFLAG) avector.C + $(ARCHIVE) libad.a avector.o + + +#************************************************************************** +# FORWARD * + +#-------------------------------------------------------------------------- +# HOS - +hos_forward.o: uni5_for.c dvlparms.h taputil.h tayutil.h \ + oplate.h usrparms.h interfaces.h adalloc.h + $(MCC) -c $(CFLAG) $(IFLAG) -o hos_forward.o \ + -D_HOS_ -D_KEEP_ uni5_for.c + $(ARCHIVE) libad.a hos_forward.o + +#-------------------------------------------------------------------------- +# FOS - +fos_forward.o: uni5_for.c dvlparms.h taputil.h tayutil.h \ + oplate.h usrparms.h interfaces.h adalloc.h + $(MCC) -c $(CFLAG) $(IFLAG) -o fos_forward.o \ + -D_FOS_ -D_KEEP_ uni5_for.c + $(ARCHIVE) libad.a fos_forward.o + +#-------------------------------------------------------------------------- +# ZOS - +zos_forward.o: uni5_for.c dvlparms.h taputil.h tayutil.h \ + oplate.h usrparms.h interfaces.h adalloc.h + $(MCC) -c $(CFLAG) $(IFLAG) -o zos_forward.o \ + -D_ZOS_ -D_KEEP_ uni5_for.c + $(ARCHIVE) libad.a zos_forward.o + +#-------------------------------------------------------------------------- +# HOV - +hov_forward.o: uni5_for.c dvlparms.h taputil.h tayutil.h \ + oplate.h usrparms.h interfaces.h adalloc.h + $(MCC) -c $(CFLAG) $(IFLAG) -o hov_forward.o \ + -D_HOV_ uni5_for.c + $(ARCHIVE) libad.a hov_forward.o + +#-------------------------------------------------------------------------- +# FOV - +fov_forward.o: uni5_for.c dvlparms.h taputil.h tayutil.h \ + oplate.h usrparms.h interfaces.h adalloc.h + $(MCC) -c $(CFLAG) $(IFLAG) -o fov_forward.o \ + -D_FOV_ uni5_for.c + $(ARCHIVE) libad.a fov_forward.o + + +#************************************************************************** +# REVERSE * + +#-------------------------------------------------------------------------- +# HOS - +hos_reverse.o: ho_rev.c dvlparms.h taputil.h tayutil.h \ + oplate.h usrparms.h interfaces.h adalloc.h convolut.h + $(MCC) -c $(CFLAG) $(IFLAG) -o hos_reverse.o \ + -D_HOS_ ho_rev.c + $(ARCHIVE) libad.a hos_reverse.o + +#-------------------------------------------------------------------------- +# FOS - +fos_reverse.o: fo_rev.c dvlparms.h taputil.h tayutil.h \ + oplate.h usrparms.h interfaces.h adalloc.h convolut.h + $(MCC) -c $(CFLAG) $(IFLAG) -o fos_reverse.o \ + -D_FOS_ fo_rev.c + $(ARCHIVE) libad.a fos_reverse.o + +#-------------------------------------------------------------------------- +# HOV - +hov_reverse.o: ho_rev.c dvlparms.h taputil.h tayutil.h \ + oplate.h usrparms.h interfaces.h adalloc.h convolut.h + $(MCC) -c $(CFLAG) $(IFLAG) -o hov_reverse.o \ + -D_HOV_ ho_rev.c + $(ARCHIVE) libad.a hov_reverse.o + +#-------------------------------------------------------------------------- +# FOV - +fov_reverse.o: fo_rev.c dvlparms.h taputil.h tayutil.h \ + oplate.h usrparms.h interfaces.h adalloc.h convolut.h + $(MCC) -c $(CFLAG) $(IFLAG) -o fov_reverse.o \ + -D_FOV_ fo_rev.c + $(ARCHIVE) libad.a fov_reverse.o + + +#************************************************************************** +# CONVOLUTION * +convolut.o: convolut.c convolut.h usrparms.h dvlparms.h + $(MCC) -c $(CFLAG) $(IFLAG) convolut.c + $(ARCHIVE) libad.a convolut.o + + +#************************************************************************** +# FORTRAN UTILITIES * +fortutils.o: fortutils.c fortutils.h usrparms.h dvlparms.h + $(MCC) -c $(CFLAG) $(IFLAG) fortutils.c + $(ARCHIVE) libad.a fortutils.o + + +#************************************************************************** +# ADALLOC * +adallocc.o: adallocc.c adalloc.h usrparms.h dvlparms.h + $(MCC) -c $(CFLAG) $(IFLAG) adallocc.c + $(ARCHIVE) libad.a adallocc.o + +adallocC.o: adallocC.C adalloc.h usrparms.h dvlparms.h + $(CC) -c $(CFLAG) $(IFLAG) adallocC.C + $(ARCHIVE) libad.a adallocC.o + + +#************************************************************************** +# ALL UTILITIES * + +#-------------------------------------------------------------------------- +# TAYLOR STUFF (TAYUTILS) - +tayutilc.o: tayutilc.c dvlparms.h usrparms.h tayutil.h + $(MCC) -c $(CFLAG) $(IFLAG) tayutilc.c + $(ARCHIVE) libad.a tayutilc.o + +tayutilC.o: tayutilC.C dvlparms.h usrparms.h tayutil.h + $(CC) -c $(CFLAG) $(IFLAG) tayutilC.C + $(ARCHIVE) libad.a tayutilC.o + +#-------------------------------------------------------------------------- +# TAPE STUFF (TAPUTILS) - +taputilc.o: taputilc.c taputil.h tayutilC.C usrparms.h dvlparms.h oplate.h + $(MCC) -c $(CFLAG) $(IFLAG) taputilc.c + $(ARCHIVE) libad.a taputilc.o + +taputilC.o: taputilC.C taputil.h usrparms.h dvlparms.h adouble.h + $(CC) -c $(CFLAG) $(IFLAG) taputilC.C + $(ARCHIVE) libad.a taputilC.o + + +#************************************************************************** +# TAPE DOCUMENTATION * +$(ADTAPEDOC)/tapedoc.o: $(ADTAPEDOC)/tapedoc.c $(ADTAPEDOC)/tapedoc.h \ + dvlparms.h taputil.h tayutil.h oplate.h usrparms.h \ + adalloc.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADTAPEDOC)/tapedoc.o \ + $(ADTAPEDOC)/tapedoc.c + $(ARCHIVE) libad.a $(ADTAPEDOC)/tapedoc.o + + +#************************************************************************** +# SPARSE * + +#-------------------------------------------------------------------------- +# INT FORWARD +$(ADSPARSE)/int_forward_t.o: $(ADSPARSE)/int_for.c dvlparms.h taputil.h \ + tayutil.h oplate.h usrparms.h adalloc.h \ + $(ADSPARSE)/jacutils.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADSPARSE)/int_forward_t.o \ + -D_INT_FOR_TIGHT_ $(ADSPARSE)/int_for.c + $(ARCHIVE) libad.a $(ADSPARSE)/int_forward_t.o + +$(ADSPARSE)/int_forward_s.o: $(ADSPARSE)/int_for.c dvlparms.h taputil.h \ + tayutil.h oplate.h usrparms.h adalloc.h \ + $(ADSPARSE)/jacutils.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADSPARSE)/int_forward_s.o \ + -D_INT_FOR_SAFE_ $(ADSPARSE)/int_for.c + $(ARCHIVE) libad.a $(ADSPARSE)/int_forward_s.o + +#-------------------------------------------------------------------------- +# INT REVERSE +$(ADSPARSE)/int_reverse_t.o: $(ADSPARSE)/int_rev.c dvlparms.h taputil.h \ + tayutil.h oplate.h usrparms.h adalloc.h \ + $(ADSPARSE)/jacutils.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADSPARSE)/int_reverse_t.o \ + -D_INT_REV_TIGHT_ $(ADSPARSE)/int_rev.c + $(ARCHIVE) libad.a $(ADSPARSE)/int_reverse_t.o + +$(ADSPARSE)/int_reverse_s.o: $(ADSPARSE)/int_rev.c dvlparms.h taputil.h \ + tayutil.h oplate.h usrparms.h adalloc.h \ + $(ADSPARSE)/jacutils.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADSPARSE)/int_reverse_s.o \ + -D_INT_REV_SAFE_ $(ADSPARSE)/int_rev.c + $(ARCHIVE) libad.a $(ADSPARSE)/int_reverse_s.o + +#-------------------------------------------------------------------------- +# JACOBIAN UTILITIES - +$(ADSPARSE)/jacutils.o: $(ADSPARSE)/jacutils.c dvlparms.h usrparms.h \ + $(ADSPARSE)/jacutils.h adalloc.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADSPARSE)/jacutils.o \ + $(ADSPARSE)/jacutils.c + $(ARCHIVE) libad.a $(ADSPARSE)/jacutils.o + +#-------------------------------------------------------------------------- +# EASY TO USE SPARSE INTERFACE - +$(ADSPARSE)/sparsec.o: $(ADSPARSE)/sparsec.c dvlparms.h usrparms.h \ + $(ADSPARSE)/jacutils.h $(ADSPARSE)/sparse.h + $(MCC) -c $(CFLAG) $(IFLAG) -o $(ADSPARSE)/sparsec.o \ + $(ADSPARSE)/sparsec.c + $(ARCHIVE) libad.a $(ADSPARSE)/sparsec.o + +$(ADSPARSE)/sparseC.o: $(ADSPARSE)/sparseC.C dvlparms.h usrparms.h \ + $(ADSPARSE)/jacutils.h $(ADSPARSE)/sparse.h + $(CC) -c $(CFLAG) $(IFLAG) -o $(ADSPARSE)/sparseC.o \ + $(ADSPARSE)/sparseC.C + $(ARCHIVE) libad.a $(ADSPARSE)/sparseC.o + + +#************************************************************************** +# CLEAN UP * +clean: + -/bin/rm *.o + -/bin/rm $(ADDRIVERS)/*.o + -/bin/rm $(ADTAPEDOC)/*.o + -/bin/rm $(ADSPARSE)/*.o + @echo clean of directory SRC finished + +cleanall: + -/bin/rm *.o + -/bin/rm $(ADDRIVERS)/*.o + -/bin/rm $(ADTAPEDOC)/*.o + -/bin/rm $(ADSPARSE)/*.o + -/bin/rm libad.a + -/bin/rm *~ + -/bin/rm $(ADDRIVERS)/*~ + -/bin/rm $(ADTAPEDOC)/*~ + -/bin/rm $(ADSPARSE)/*~ + @echo cleanall of directory SRC finished + diff --git a/adol-c/INS/makefile.ori b/adol-c/INS/makefile.ori new file mode 100644 index 0000000..a08d92e --- /dev/null +++ b/adol-c/INS/makefile.ori @@ -0,0 +1,186 @@ +#************************************************************************** +# +# -------------------------------------------------------------- +# makefile (INS) of ADOL-C version 1.8.7 as of Mar/10/2000 +# -------------------------------------------------------------- +# makefile for generating all other makefiles and total clean up +# +#************************************************************************** + +COMPONENTS = makefile.DEX.head makefile.DEX.tail \ + makefile.EXA.head makefile.EXA.tail \ + makefile.EXA.ODE.head makefile.EXA.ODE.tail \ + makefile.EXA.TIMING.head makefile.EXA.TIMING.tail \ + makefile.EXA.TAYLOR.head makefile.EXA.TAYLOR.tail \ + makefile.EXA.TS.head makefile.EXA.TS.tail \ + makefile.EXA.SPARSE.head makefile.EXA.SPARSE.tail \ + makefile.EXA.LH.head makefile.EXA.LH.tail \ + makefile.EXA.LU.head makefile.EXA.LU.tail \ + makefile.EXA.CLOCK.head makefile.EXA.CLOCK.tail \ + makefile.SRC.head makefile.SRC.tail + + +gnuinstall: $(COMPONENTS) gnu_comp + cat makefile.DEX.head gnu_comp makefile.DEX.tail > ../DEX/makefile + cat makefile.EXA.head gnu_comp makefile.EXA.tail > ../EXA/makefile + cat makefile.EXA.ODE.head gnu_comp makefile.EXA.ODE.tail \ + > ../EXA/ODE/makefile + cat makefile.EXA.TIMING.head gnu_comp makefile.EXA.TIMING.tail \ + > ../EXA/TIMING/makefile + cat makefile.EXA.TAYLOR.head gnu_comp makefile.EXA.TAYLOR.tail \ + > ../EXA/TAYLOR/makefile + cat makefile.EXA.TS.head gnu_comp makefile.EXA.TS.tail \ + > ../EXA/TAPESAVE/makefile + cat makefile.EXA.SPARSE.head gnu_comp makefile.EXA.SPARSE.tail \ + > ../EXA/SPARSE/makefile + cat makefile.EXA.LH.head gnu_comp makefile.EXA.LH.tail \ + > ../EXA/LIGHTHOUSE/makefile + cat makefile.EXA.LU.head gnu_comp makefile.EXA.LU.tail \ + > ../EXA/LUFACT/makefile + cat makefile.EXA.CLOCK.head gnu_comp makefile.EXA.CLOCK.tail \ + > ../EXA/CLOCK/makefile + cat makefile.SRC.head gnu_comp makefile.SRC.tail > ../SRC/makefile + @echo installation of makefiles finished + + +aixinstall: $(COMPONENTS) aix_comp + cat makefile.DEX.head aix_comp makefile.DEX.tail > ../DEX/makefile + cat makefile.EXA.head aix_comp makefile.EXA.tail > ../EXA/makefile + cat makefile.EXA.ODE.head aix_comp makefile.EXA.ODE.tail \ + > ../EXA/ODE/makefile + cat makefile.EXA.TIMING.head aix_comp makefile.EXA.TIMING.tail \ + > ../EXA/TIMING/makefile + cat makefile.EXA.TAYLOR.head aix_comp makefile.EXA.TAYLOR.tail \ + > ../EXA/TAYLOR/makefile + cat makefile.EXA.TS.head aix_comp makefile.EXA.TS.tail \ + > ../EXA/TAPESAVE/makefile + cat makefile.EXA.SPARSE.head aix_comp makefile.EXA.SPARSE.tail \ + > ../EXA/SPARSE/makefile + cat makefile.EXA.LH.head aix_comp makefile.EXA.LH.tail \ + > ../EXA/LIGHTHOUSE/makefile + cat makefile.EXA.LU.head aix_comp makefile.EXA.LU.tail \ + > ../EXA/LUFACT/makefile + cat makefile.EXA.CLOCK.head aix_comp makefile.EXA.CLOCK.tail \ + > ../EXA/CLOCK/makefile + cat makefile.SRC.head aix_comp makefile.SRC.tail > ../SRC/makefile + @echo installation of makefiles finished + + +suninstall: $(COMPONENTS) sun_comp + cat makefile.DEX.head sun_comp makefile.DEX.tail > ../DEX/makefile + cat makefile.EXA.head sun_comp makefile.EXA.tail > ../EXA/makefile + cat makefile.EXA.ODE.head sun_comp makefile.EXA.ODE.tail \ + > ../EXA/ODE/makefile + cat makefile.EXA.TIMING.head sun_comp makefile.EXA.TIMING.tail \ + > ../EXA/TIMING/makefile + cat makefile.EXA.TAYLOR.head sun_comp makefile.EXA.TAYLOR.tail \ + > ../EXA/TAYLOR/makefile + cat makefile.EXA.TS.head sun_comp makefile.EXA.TS.tail \ + > ../EXA/TAPESAVE/makefile + cat makefile.EXA.SPARSE.head sun_comp makefile.EXA.SPARSE.tail \ + > ../EXA/SPARSE/makefile + cat makefile.EXA.LH.head sun_comp makefile.EXA.LH.tail \ + > ../EXA/LIGHTHOUSE/makefile + cat makefile.EXA.LU.head sun_comp makefile.EXA.LU.tail \ + > ../EXA/LUFACT/makefile + cat makefile.EXA.CLOCK.head sun_comp makefile.EXA.CLOCK.tail \ + > ../EXA/CLOCK/makefile + cat makefile.SRC.head sun_comp makefile.SRC.tail > ../SRC/makefile + @echo installation of makefiles finished + + +decinstall: $(COMPONENTS) dec_comp + cat makefile.DEX.head dec_comp makefile.DEX.tail > ../DEX/makefile + cat makefile.EXA.head dec_comp makefile.EXA.tail > ../EXA/makefile + cat makefile.EXA.ODE.head dec_comp makefile.EXA.ODE.tail \ + > ../EXA/ODE/makefile + cat makefile.EXA.TIMING.head dec_comp makefile.EXA.TIMING.tail \ + > ../EXA/TIMING/makefile + cat makefile.EXA.TAYLOR.head dec_comp makefile.EXA.TAYLOR.tail \ + > ../EXA/TAYLOR/makefile + cat makefile.EXA.TS.head dec_comp makefile.EXA.TS.tail \ + > ../EXA/TAPESAVE/makefile + cat makefile.EXA.SPARSE.head dec_comp makefile.EXA.SPARSE.tail \ + > ../EXA/SPARSE/makefile + cat makefile.EXA.LH.head dec_comp makefile.EXA.LH.tail \ + > ../EXA/LIGHTHOUSE/makefile + cat makefile.EXA.LU.head dec_comp makefile.EXA.LU.tail \ + > ../EXA/LUFACT/makefile + cat makefile.EXA.CLOCK.head dec_comp makefile.EXA.CLOCK.tail \ + > ../EXA/CLOCK/makefile + cat makefile.SRC.head dec_comp makefile.SRC.tail > ../SRC/makefile + @echo installation of makefiles finished + + +sgiinstall: $(COMPONENTS) sgi_comp + cat makefile.DEX.head sgi_comp makefile.DEX.tail > ../DEX/makefile + cat makefile.EXA.head sgi_comp makefile.EXA.tail > ../EXA/makefile + cat makefile.EXA.ODE.head sgi_comp makefile.EXA.ODE.tail \ + > ../EXA/ODE/makefile + cat makefile.EXA.TIMING.head sgi_comp makefile.EXA.TIMING.tail \ + > ../EXA/TIMING/makefile + cat makefile.EXA.TAYLOR.head sgi_comp makefile.EXA.TAYLOR.tail \ + > ../EXA/TAYLOR/makefile + cat makefile.EXA.TS.head sgi_comp makefile.EXA.TS.tail \ + > ../EXA/TAPESAVE/makefile + cat makefile.EXA.SPARSE.head sgi_comp makefile.EXA.SPARSE.tail \ + > ../EXA/SPARSE/makefile + cat makefile.EXA.LH.head sgi_comp makefile.EXA.LH.tail \ + > ../EXA/LIGHTHOUSE/makefile + cat makefile.EXA.LU.head sgi_comp makefile.EXA.LU.tail \ + > ../EXA/LUFACT/makefile + cat makefile.EXA.CLOCK.head sgi_comp makefile.EXA.CLOCK.tail \ + > ../EXA/CLOCK/makefile + cat makefile.SRC.head sgi_comp makefile.SRC.tail > ../SRC/makefile + @echo installation of makefiles finished + + +xxxinstall: $(COMPONENTS) xxx_comp + cat makefile.DEX.head xxx_comp makefile.DEX.tail > ../DEX/makefile + cat makefile.EXA.head xxx_comp makefile.EXA.tail > ../EXA/makefile + cat makefile.EXA.ODE.head xxx_comp makefile.EXA.ODE.tail \ + > ../EXA/ODE/makefile + cat makefile.EXA.TIMING.head xxx_comp makefile.EXA.TIMING.tail \ + > ../EXA/TIMING/makefile + cat makefile.EXA.TAYLOR.head xxx_comp makefile.EXA.TAYLOR.tail \ + > ../EXA/TAYLOR/makefile + cat makefile.EXA.TS.head xxx_comp makefile.EXA.TS.tail \ + > ../EXA/TAPESAVE/makefile + cat makefile.EXA.SPARSE.head xxx_comp makefile.EXA.SPARSE.tail \ + > ../EXA/SPARSE/makefile + cat makefile.EXA.LH.head xxx_comp makefile.EXA.LH.tail \ + > ../EXA/LIGHTHOUSE/makefile + cat makefile.EXA.LU.head xxx_comp makefile.EXA.LU.tail \ + > ../EXA/LUFACT/makefile + cat makefile.EXA.CLOCK.head xxx_comp makefile.EXA.CLOCK.tail \ + > ../EXA/CLOCK/makefile + cat makefile.SRC.head xxx_comp makefile.SRC.tail > ../SRC/makefile + @echo installation of makefiles finished + + +uninstall: + ( cd ../DEX; make cleanall) + -rm ../DEX/makefile + ( cd ../EXA; make cleanall; make cleanallsubdirs) + -rm ../EXA/makefile + -rm ../EXA/CLOCK/makefile + -rm ../EXA/ODE/makefile + -rm ../EXA/SPARSE/makefile + -rm ../EXA/TAYLOR/makefile + -rm ../EXA/TAPESAVE/makefile + -rm ../EXA/LIGHTHOUSE/makefile + -rm ../EXA/LUFACT/makefile + -rm ../EXA/TIMING/makefile + ( cd ../SRC; make cleanall) + -rm ../SRC/makefile + -rm *~ + @echo uninstallation finished + + + + + + + + + diff --git a/adol-c/INS/sgi_comp b/adol-c/INS/sgi_comp new file mode 100644 index 0000000..783be1c --- /dev/null +++ b/adol-c/INS/sgi_comp @@ -0,0 +1,35 @@ +#************************************************************************** +# Which compilers do you use? COMPILER * +CC = CC -w # C++ +MCC = cc -w # C + + +#************************************************************************** +# COMPILER FLAGS * +# GENERAL FLAGS (e. g. optimization) +#CFLAG = -g +#CFLAG = +#CFLAG = -O +CFLAG = -O2 + +# INCLUDES +IFLAG = -I$(ADHEADERS) + +# LIBRARIES (COMPILING) +LFLAG = -L$(ADLIB) + +# LIBRARIES (LINKING) +LIBS = -lad -lm + +# PREPROCESSOR FLAGS +PPFLAGS = -E -C + + +#************************************************************************** +# ar/ranlib utility LIBRARY TOOLS * +ARCHIVE = ar rcv +RANLIB = ar qs +# RANLIB =`if [ -r /bin/ranlib -o -r /usr/bin/ranlib ]; \ +# then echo ranlib; else echo true; fi` + + diff --git a/adol-c/INS/sun_comp b/adol-c/INS/sun_comp new file mode 100644 index 0000000..6bb83d0 --- /dev/null +++ b/adol-c/INS/sun_comp @@ -0,0 +1,35 @@ +#************************************************************************** +# Which compilers do you use? COMPILER * +CC = CC # C++ +MCC = cc -xCC # C + + +#************************************************************************** +# COMPILER FLAGS * +# GENERAL FLAGS (e. g. optimization) +#CFLAG = -g +#CFLAG = +#CFLAG = -O +CFLAG = -O2 + +# INCLUDES +IFLAG = -I$(ADHEADERS) + +# LIBRARIES (COMPILING) +LFLAG = -L$(ADLIB) + +# LIBRARIES (LINKING) +LIBS = -lad -lm + +# PREPROCESSOR FLAGS +PPFLAGS = -E -C + + +#************************************************************************** +# ar/ranlib utility LIBRARY TOOLS * +ARCHIVE = ar rcv +RANLIB = ar qs +# RANLIB =`if [ -r /bin/ranlib -o -r /usr/bin/ranlib ]; \ +# then echo ranlib; else echo true; fi` + + diff --git a/adol-c/INS/xxx_comp b/adol-c/INS/xxx_comp new file mode 100644 index 0000000..a7d3ff6 --- /dev/null +++ b/adol-c/INS/xxx_comp @@ -0,0 +1,40 @@ +include ../../makedefs + +CC = $(ADOL_CC) +MCC = $(ADOL_MCC) +CFLAG = $(ADOL_CFLAGS) + +#************************************************************************** +# Which compilers do you use? COMPILER * +#CC = g++ # C++ +#MCC = gcc # C + + +#************************************************************************** +# COMPILER FLAGS * +# GENERAL FLAGS (e. g. optimization) +#CFLAG = -g +#CFLAG = +#CFLAG = -O +#CFLAG = -O2 + +# INCLUDES +IFLAG = -I$(ADHEADERS) # uncomment if necessary -I/usr/lib/g++-include + +# LIBRARIES (COMPILING) +LFLAG = -L$(ADLIB) + +# LIBRARIES (LINKING) +LIBS = -lad -lm + +# PREPROCESSOR FLAGS +PPFLAGS = -trigraphs -E -C + + +#************************************************************************** +# ar/ranlib utility LIBRARY TOOLS * +ARCHIVE = ar rcv +RANLIB = ar qs +# RANLIB =`if [ -r /bin/ranlib -o -r /usr/bin/ranlib ]; \ +# then echo ranlib; else echo true; fi` + diff --git a/adol-c/INS/xxx_comp.ori b/adol-c/INS/xxx_comp.ori new file mode 100644 index 0000000..a0fb18b --- /dev/null +++ b/adol-c/INS/xxx_comp.ori @@ -0,0 +1,37 @@ +#************************************************************************** +# Which compilers do you use? COMPILER * +CC = CC # C++ +MCC = cc # C + + +#************************************************************************** +# COMPILER FLAGS * +# GENERAL FLAGS (e. g. optimization) +#CFLAG = -g +#CFLAG = +#CFLAG = -O +CFLAG = -O2 + +# INCLUDES +IFLAG = -I$(ADHEADERS) -I/usr/lib/g++-include + +# LIBRARIES (COMPILING) +LFLAG = -L$(ADLIB) + +# LIBRARIES (LINKING) +LIBS = -lad -lm + +# PREPROCESSOR FLAGS +PPFLAGS = -E -C + + +#************************************************************************** +# ar/ranlib utility LIBRARY TOOLS * +ARCHIVE = ar rcv +RANLIB = ar qs +# RANLIB =`if [ -r /bin/ranlib -o -r /usr/bin/ranlib ]; \ +# then echo ranlib; else echo true; fi` + + + + diff --git a/adol-c/README b/adol-c/README new file mode 100644 index 0000000..cdec6a1 --- /dev/null +++ b/adol-c/README @@ -0,0 +1,40 @@ +-------------------------------------------------------------- +README ADOL-C version 1.8.7 as of MAR/10/2000 +-------------------------------------------------------------- + +ADOL-C = Automatic Differentiation by Overloading in C/C++ + +-------------------------------------------------------------- + +The ADOL-C package is divided into following subdirectories + + SRC --> ADOL-C source to create the library libad.a + INS --> Installation scripts and makefiles + DOC --> LaTeX source and Postscript version of the manual + DEX --> Documented examples + EXA --> More examples + +-------------------------------------------------------------- + +Detailed information about design goals, application, +implementation details, and installation of ADOL-C 1.8 can be +found in the manual + + DOC/adolc18.ps + +and the READMEs placed in each subdirectory. + +-------------------------------------------------------------- + +Any difficulties and questions should be reported to: + + adol-c@math.tu-dresden.de + +-------------------------------------------------------------- + +Updates and new versions of ADOL-C can be found at + + http://www.math.tu-dresden.de/~adol-c + ftp://ftp.math.tu-dresden.de/pub/ADOLC + +-------------------------------------------------------------- diff --git a/adol-c/SRC/DRIVERS/drivers.c b/adol-c/SRC/DRIVERS/drivers.c new file mode 100644 index 0000000..9f43655 --- /dev/null +++ b/adol-c/SRC/DRIVERS/drivers.c @@ -0,0 +1,399 @@ +#define _DRIVERSC_C_ +#define _ADOLC_SRC_ +/* + ------------------------------------------------------------------------ + File driversc.c of ADOL-C version 1.8.7 as of Feb/28/2000 + ------------------------------------------------------------------------ + Easy to use drivers for optimization and nonlinear equations + (Implementation of the C/C++ callable interfaces). + + Last changed : + 20000228 olvo: corrected comment at lagra_hess_vec + 990622 olvo: jacobian(..) makes decision to use forward only or + a reverse sweep + 981130 olvo: newly created from old wersion (which was splitted) + 981126 olvo: last check (p's & q's) + 981020 olvo: deleted debug messages in tensor + + ------------------------------------------------------------------------ +*/ + + +/****************************************************************************/ +/* INCLUDES */ +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" /* Users Parameters */ +#include "drivers.h" +#include "interfaces.h" +#include "adalloc.h" + +#include +#include + +#ifdef __cplusplus +#include +extern "C" { +#endif + + +/****************************************************************************/ +/* MACROS */ + +#define maxinc(a,b) if ((a) < (b)) (a) = (b) +#define mindec(a,b) if ((a) > (b)) (a) = (b) + + +/****************************************************************************/ +/* DRIVERS FOR OPTIMIZATION AND NONLINEAR EQUATIONS */ + +/*--------------------------------------------------------------------------*/ +/* function */ +/* function(tag, m, n, x[n], y[m]) */ + +int function(short tag, + int m, + int n, + double* argument, + double* result) +{ + int rc= -1; + + rc= zos_forward(tag,m,n,0,argument,result); + + return rc; +} + +/*--------------------------------------------------------------------------*/ +/* gradient */ +/* gradient(tag, n, x[n], g[n]) */ + +static double one = 1.0; + +int gradient(short tag, + int n, + double* argument, + double* result) +{ + int rc= -1; + + rc = zos_forward(tag,1,n,1,argument,result); + if(rc < 0) + return rc; + maxinc(rc, fos_reverse(tag,1,n,&one,result)); + return rc; +} + + +/*--------------------------------------------------------------------------*/ +/* */ +/* vec_jac(tag, m, n, repeat, x[n], u[m], v[n]) */ + +int vec_jac(short tag, + int m, + int n, + int repeat, + double* argument, + double* lagrange, + double* row) +{ + int rc= -1; + static double *y; + static int maxm; + if(m > maxm) + { + if(maxm) + free((char*)y); + y = myalloc1(m); + maxm = m; + } + if(!repeat) { + rc = zos_forward(tag,m,n,1, argument, y); + if(rc < 0) + return rc; + } + maxinc(rc, fos_reverse(tag,m,n,lagrange,row)); + return rc; +} + + +/*--------------------------------------------------------------------------*/ +/* jacobian */ +/* jacobian(tag, m, n, x[n], J[m][n]) */ + +int jacobian(short tag, + int depen, + int indep, + double *argument, + double **jacobian) +{ int rc; + static int nmmax; // dim for I + static int mmax; // dim for result + static double *result, **I; + + if (depen > mmax) + { if (mmax) + myfree1(result); + result = myalloc1(mmax = depen); + } + + if (indep/2 < depen) + { if (indep > nmmax) + { if (nmmax) + myfreeI2(nmmax,I); + I = myallocI2(nmmax = indep); + } + rc = fov_forward(tag,depen,indep,indep,argument,I,result,jacobian); + } + else + { if (depen > nmmax) + { if (nmmax) + myfreeI2(nmmax,I); + I = myallocI2(nmmax = depen); + } + rc = zos_forward(tag,depen,indep,1,argument,result); + if (rc < 0) + return rc; + maxinc(rc,fov_reverse(tag,depen,indep,depen,I,jacobian)); + } + return rc; +} + + +/*--------------------------------------------------------------------------*/ +/* */ +/* jac_vec(tag, m, n, x[n], v[n], u[m]); */ + +int jac_vec(short tag, + int m, + int n, + double* argument, + double* tangent, + double* column) +{ + int rc= -1; + static double *y; + static int maxm; + if(m > maxm ) + { + if(maxm) + myfree1(y); + y = myalloc1(m); + maxm = m; + } + + rc = fos_forward(tag, m, n, 0, argument, tangent, y, column); + + return rc; +} + + +/*--------------------------------------------------------------------------*/ +/* */ +/* hess_vec(tag, n, x[n], v[n], w[n]) */ + +int hess_vec(short tag, + int n, + double *argument, + double *tangent, + double *result) +{ + return lagra_hess_vec(tag,1,n,argument,tangent,&one,result); +} + + +/*--------------------------------------------------------------------------*/ +/* hessian */ +/* hessian(tag, n, x[n], lower triangle of H[n][n]) */ + +int hessian(short tag, + int n, + double* argument, + double** hess) +{ + int rc= 3; + int i,j; + double *v = myalloc1(n); + double *w = myalloc1(n); + for(i=0;i maxn || m > maxm) + { + if (X){ free((char*)*X); free((char*)X);} + X = myalloc2(n,2); + maxn = n; + if (y) free((char*)y); + if (y_tangent) free((char*)y_tangent); + y = myalloc1(m); + y_tangent = myalloc1(m); + } + + rc = fos_forward(tag,m,n,keep, argument, tangent, y, y_tangent); + + if(rc < 0) + return rc; + + for(i=0;i +#include + +#ifdef __cplusplus +#include +extern "C" { +#endif + + +/****************************************************************************/ +/* MACROS */ + +#define maxinc(a,b) if ((a) < (b)) (a) = (b) +#define mindec(a,b) if ((a) > (b)) (a) = (b) + + +/****************************************************************************/ +/* DRIVERS FOR OPTIMIZATION AND NONLINEAR EQUATIONS */ + +/*--------------------------------------------------------------------------*/ +/* function */ +/* function(tag, m, n, x[n], y[m]) */ + +fint function_(fint* ftag, + fint* fm, + fint* fn, + fdouble* fargument, + fdouble* fresult) +{ + int rc= -1; + int tag=*ftag, m=*fm, n=*fn; + double* argument = myalloc1(n); + double* result = myalloc1(m); + spread1(n,fargument,argument); + rc= function(tag,m,n,argument,result); + pack1(m,result,fresult); + free((char*)argument); free((char*)result); + return rc; +} + + +/*--------------------------------------------------------------------------*/ +/* gradient */ +/* gradient(tag, n, x[n], g[n]) */ + +fint gradient_(fint* ftag, + fint* fn, + fdouble* fargument, + fdouble* fresult) +{ + int rc= -1; + int tag=*ftag, n=*fn; + double* argument=myalloc1(n); + double* result=myalloc1(n); + spread1(n,fargument,argument); + rc= gradient(tag,n,argument,result); + pack1(n,result,fresult); + free((char*)result); free((char*)argument); + return rc; +} + + +/*--------------------------------------------------------------------------*/ +/* */ +/* vec_jac(tag, m, n, repeat, x[n], u[m], v[n]) */ + +fint vec_jac_(fint* ftag, + fint* fm, + fint* fn, + fint* frepeat, + fdouble* fargument, + fdouble* flagrange, + fdouble* frow) +{ + int rc= -1; + int tag=*ftag, m=*fm, n=*fn, repeat=*frepeat; + double* argument = myalloc1(n); + double* lagrange = myalloc1(m); + double* row = myalloc1(n); + spread1(m,flagrange,lagrange); + spread1(n,fargument,argument); + rc= vec_jac(tag,m,n,repeat,argument,lagrange, row); + pack1(n,row,frow); + free((char*)argument); free((char*)lagrange); free((char*)row); + return rc; +} + + +/*--------------------------------------------------------------------------*/ +/* jacobian */ +/* jacobian(tag, m, n, x[n], J[m][n]) */ + +fint jacobian_(fint* ftag, + fint* fdepen, + fint* findep, + fdouble *fargument, + fdouble *fjac) +{ + int rc= -1; + int tag=*ftag, depen=*fdepen, indep=*findep; + double** Jac = myalloc2(depen,indep); + double* argument = myalloc1(indep); + spread1(indep,fargument,argument); + rc= jacobian(tag,depen,indep,argument,Jac); + pack2(depen,indep,Jac,fjac); + free((char*)*Jac); free((char*)Jac); + free((char*)argument); + return rc; +} + + +/*--------------------------------------------------------------------------*/ +/* */ +/* jac_vec(tag, m, n, x[n], v[n], u[m]); */ + +fint jac_vec_(fint* ftag, + fint* fm, + fint* fn, + fdouble* fargument, + fdouble* ftangent, + fdouble* fcolumn) +{ + int rc= -1; + int tag=*ftag, m=*fm, n=*fn; + double* argument = myalloc1(n); + double* tangent = myalloc1(n); + double* column = myalloc1(m); + spread1(n,ftangent,tangent); + spread1(n,fargument,argument); + rc= jac_vec(tag,m,n,argument,tangent,column); + pack1(m,column,fcolumn); + free((char*)argument); free((char*)tangent); free((char*)column); + return rc; +} + + +/*--------------------------------------------------------------------------*/ +/* */ +/* hess_vec(tag, n, x[n], v[n], w[n]) */ + +fint hess_vec_(fint* ftag, + fint* fn, + fdouble *fargument, + fdouble *ftangent, + fdouble *fresult) +{ + int rc= -1; + int tag=*ftag, n=*fn; + double *argument = myalloc1(n); + double *tangent = myalloc1(n); + double *result = myalloc1(n); + spread1(n,fargument,argument); + spread1(n,ftangent,tangent); + rc= hess_vec(tag,n,argument,tangent,result); + pack1(n,result,fresult); + free((char*)argument); free((char*)tangent); free((char*)result); + return rc; +} + + +/*--------------------------------------------------------------------------*/ +/* hessian */ +/* hessian(tag, n, x[n], lower triangle of H[n][n]) */ + +fint hessian_(fint* ftag, + fint* fn, + fdouble* fx, + fdouble* fh) /* length of h should be n*n but the + upper half of this matrix remains unchanged */ +{ + int rc= -1; + int tag=*ftag, n=*fn; + int i; + double** H = myalloc2(n,n); + double* x = myalloc1(n); + spread1(n,fx,x); + rc= hessian(tag,n,x,H); + pack2(n,n,H,fh); + free((char*)*H); free((char*)H); + free((char*)x); + return rc; +} + + +/*--------------------------------------------------------------------------*/ +/* */ +/* lagra_hess_vec(tag, m, n, x[n], v[n], u[m], w[n]) */ + +fint lagra_hess_vec_(fint* ftag, + fint* fm, + fint* fn, + fdouble *fargument, + fdouble *ftangent, + fdouble *flagrange, + fdouble *fresult) +{ + int rc=-1; + int tag=*ftag, m=*fm, n=*fn; + double *argument = myalloc1(n); + double *tangent = myalloc1(n); + double *lagrange = myalloc1(m); + double *result = myalloc1(n); + spread1(n,fargument,argument); + spread1(n,ftangent,tangent); + spread1(m,flagrange,lagrange); + rc= lagra_hess_vec(tag,m,n,argument,tangent,lagrange,result); + pack1(n,result,fresult); + free((char*)argument); free((char*)tangent); free((char*)lagrange); + free((char*)result); + return rc; +} + + +/****************************************************************************/ +/* THAT'S ALL */ + +#ifdef __cplusplus +} +#endif + +#undef _ADOLC_SRC_ +#undef _DRIVERSF_C_ diff --git a/adol-c/SRC/DRIVERS/odedrivers.c b/adol-c/SRC/DRIVERS/odedrivers.c new file mode 100644 index 0000000..9d4a481 --- /dev/null +++ b/adol-c/SRC/DRIVERS/odedrivers.c @@ -0,0 +1,267 @@ +#define _ODEDRIVERSC_C_ +#define _ADOLC_SRC_ +/* + ------------------------------------------------------------------------ + File odedriversc.c of ADOL-C version 1.8.0 as of Dec/01/98 + ------------------------------------------------------------------------ + Easy to use drivers for ordinary differential equations (ODE) + (Implementation of the C/C++ callable interfaces). + + Last changes: + 981201 olvo: newly created from driversc.c + + ------------------------------------------------------------------------ +*/ + + +/****************************************************************************/ +/* INCLUDES */ +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" /* Users Parameters */ +#include "odedrivers.h" +#include "interfaces.h" +#include "adalloc.h" + +#include +#include + +#ifdef __cplusplus +#include +extern "C" { +#endif + + +/****************************************************************************/ +/* MACROS */ + +#define maxinc(a,b) if ((a) < (b)) (a) = (b) +#define mindec(a,b) if ((a) > (b)) (a) = (b) + + +/****************************************************************************/ +/* DRIVERS FOR ODEs */ + +/*--------------------------------------------------------------------------*/ +/* forodec */ +/* forodec(tag, n, tau, dold, dnew, X[n][d+1]) */ + +int forodec(short tag, /* tape identifier */ + int n, /* space dimension */ + double tau, /* scaling defaults to 1.0 */ + int dol, /* previous degree defaults to zero */ + int deg, /* New degree of consistency */ + double** Y) /* Taylor series */ +{ + /********************************************************************* + This is assumed to be the autonomous case. + Here we are just going around computing the vectors + y[][j] for dol < j <= deg + by successive calls to forward that works on the tape identified + by tag. This tape (array of file) must obviously have been + generated by a the execution of an active section between + trace_on and trace_off with n independent and n dependent variables + y must have been set up as pointer to an array of n pointers + to double arrays containing at least deg+1 components. + The scaling by tau is sometimes necessary to avoid overflow. + **********************************************************************/ + + int rc= 3; + static int i, j, k, nax, dax; + static double *y, *z, **Z, taut; + if ( n > nax || deg > dax ) + { + if (nax) {free((char*) *Z); free((char*) Z); + free((char*) z);free((char*) y);} + Z = myalloc2(n,deg); + z = myalloc1(n); + y = myalloc1(n); + nax = n; + dax = deg; + } + + for (i=0;i0;k--) + { + Y[i][k] = Y[i][k-1]; + /*printf("Y[%i][%i] = %f\n",i,k,Y[i][k]);*/ + } + Y[i][0] = y[i]; + /*printf("Y[%i][0] = %f\n",i,Y[i][0]);*/ + } + + return rc; +} + +/*--------------------------------------------------------------------------*/ +/* accodec */ +/* accodec(n, tau, d, Z[n][n][d+1], B[n][n][d+1], nz[n][n]) */ + +void accodec(int n, /* space dimension */ + double tau, /* scaling defaults to 1.0 */ + int deg, /* highest degree */ + double*** A, /* input tensor of "partial" Jacobians */ + double*** B, /* output tensor of "total" Jacobians */ + short** nonzero ) /* optional sparsity characterization */ +{ +/* + The purpose of this subroutine is to compute the total derivatives + B[i=0...n-1][j=0...n-1][k=0...deg]. + The matrix obtained for fixed k represents the Jacobian of the + (k+1)-st Taylor coefficient vector with respect to the base point of + the ODE, i.e., the 0-th coefficient vector. The input array + A[i=0...n-1][j=0...n-1][k=0...deg] + has exactly the same format, except that it-s k-th matrix slice + represents a partial derivative in that the indirect dependence + of the k-th coefficient vector on the base point via the (k-1)-st + and other lower Taylor coeffcients has not been taken into account. + The B's are compute from the A's by the chainrule with the parameter + tau thrown in for scaling. The calculation is performed so that + A may directly be overwritten by B i.e. their pointers arguments may + coincide to save storage. + Sparsity is used so far only to reduce the operations count + but not to save space. In general we expect that for each given pair + (i,j) the entries A[i][j][k=0...] are nonzero either for all k, or for no k, + or for k=0 only. + On entry the optional short array nonzero may be used to identify + all entries of the A[.][.][k] that are potentially nonzero, i.e. + + nonzero[i][j] <= 0 implies A[i][j][k] = 0 for all k + nonzero[i][j] = 1 implies A[i][j][k] = 0 for all k > 0 . + + In other words we only allow the sparsity of the matrices A[.][.][k] + to be increasing in that A[.][.][1] is possibly sparser than A[.][.][0] + and all subseqent A[.][.][k] with k > 0 have the same sparsity pattern. + That is the typical situation since A[.][.][k] is the k-th + Taylor coefficient in the time expansion of the Jacobian of the + right hand side. The entries of this square matrix tend to be either + constant or trancendental functions of time. + The matrices B_k = B[.][.][k] are obtained from the A_k = A[.][.][k] + by the recurrence + tau / k \ + B_k = ----- | A_k + SUM A_{j-1} B_{k-j} | + k+1 \ j=1 / + + Assuming that the diagonal entries A[i][i][0] are structurally nonzero + we find that the matrices B[.][.][k=1..] can only lose sparsity + as k increase. Therfore, we can redefine the nonpositive values + nonzero[i][j] so that on exit + + k <= -nonzero[i][j] implies B[i][j][k] = 0 + + which is trivially satisfied for all positive values of nonzero[i][j]. + Due to the increasing sparsity of the A_i and the decreasing sparsity + of the B_i the first product in the sum of the RHS above determines the + sparsity pattern of the resulting B_k. Hence the optimal values of + the nonzero[i][j] depend only on the sparsity pattern of A_0. More + specifically, all positive -nonzero[i][j] represent the length of the + shortest directed path connecting nodes j and i in the incidence graph + of A_0. +*/ + + int i,j,k,m,p,nzip,nzpj,isum; + double *Aip, *Bpj, scale, sum; + for (k=0;k<=deg;k++) /* Lets calculate B_k */ + { + scale = tau/(1.0+k); + if(nonzero) + { + for (i=0;i 0); + for (p=0;p 0) nzpj = 0; + if(nzip > 0 && k > -nzpj ) /*otherwise all terms vanish*/ + { + Aip = A[i][p]; + Bpj = B[p][j]+k-1; + sum += *Aip*(*Bpj); + isum =1; + if(nzip > 1 ) /* the A[i][p][m>0] may be nonzero*/ + for(m=k-1; m>-nzpj;m--) + sum += *(++Aip)*(*(--Bpj)); + } + } + if(isum) /* we found something nonzero after all*/ + B[i][j][k] = sum*scale; + else + {B[i][j][k]= 0; + nonzero[i][j]--; + } + } + } + else + { + for (i=0;i0 ;m--) + sum += *(Aip++)*(*Bpj--); + B[i][j][k] = sum*scale; + } + } + } + } +} + + +/****************************************************************************/ +/* THAT'S ALL */ + +#ifdef __cplusplus +} +#endif + +#undef _ADOLC_SRC_ +#undef _ODEDRIVERSC_C_ diff --git a/adol-c/SRC/DRIVERS/odedrivers.h b/adol-c/SRC/DRIVERS/odedrivers.h new file mode 100644 index 0000000..e77faf4 --- /dev/null +++ b/adol-c/SRC/DRIVERS/odedrivers.h @@ -0,0 +1,115 @@ +#ifndef _ODEDRIVERS_H_ +#define _ODEDRIVERS_H_ +/* + ------------------------------------------------------------- + File odedrivers.h of ADOL-C version 1.8.0 as of Dec/01/98 + ------------------------------------------------------------- + Easy to use drivers for ordinary differential equations (ODE) + (with C and C++ callable interfaces including Fortran + callable versions). + + Last changes: + 981201 olvo: newly created from adutils.h & adutilsc.h + + ------------------------------------------------------------- +*/ + +/****************************************************************************/ +/****************************************************************************/ +/****************************************************************************/ +/* PUBLIC EXPORTS ONLY */ + +#ifdef __cplusplus +/****************************************************************************/ +/****************************************************************************/ +/* Now the C++ THINGS */ + + +/****************************************************************************/ +/* DRIVERS FOR ODEs, overloaded calls */ + +/*--------------------------------------------------------------------------*/ +/* forode */ +/* forode(tag, n, tau, dold, dnew, X[n][d+1]) */ + +int forode(short, int, double, int, int, double**); + +/*--------------------------------------------------------------------------*/ +/* forode */ +/* the scaling tau defaults to 1 */ +/* */ +/* forode(tag, n, dold, dnew, X[n][d+1]) */ + +int forode(short, int, /*1.0,*/ int, int, double**); + +/*--------------------------------------------------------------------------*/ +/* forode */ +/* previous order defaults to 0 */ +/* */ +/* forode(tag, n, tau, dnew, X[n][d+1]) */ + +int forode(short, int, double, /*0,*/ int, double**); + +/*--------------------------------------------------------------------------*/ +/* forode */ +/* both tau and dold default */ +/* */ +/* forode(tag, n, dnew, X[n][d+1]) */ + +int forode(short, int, /*1.0 , 0,*/ int, double**); + +/*--------------------------------------------------------------------------*/ +/* accode */ +/* accode(n, tau, d, Z[n][n][d+1], B[n][n][d+1], nz[n][n]) */ + +void accode(int, double, int, double***, double***, short** = 0 ); + +/*--------------------------------------------------------------------------*/ +/* accode */ +/* scaling defaults to 1 */ +/* */ +/* accode(n, d, Z[n][n][d+1], B[n][n][d+1], nz[n][n]) */ + +void accode(int, /*1.0,*/ int, double***, double***, short** = 0 ); + + +/****************************************************************************/ +/****************************************************************************/ +/* Now the C THINGS */ +extern "C" { +#endif + + +/****************************************************************************/ +/* DRIVERS FOR ODEs */ + +/*--------------------------------------------------------------------------*/ +/* forodec */ +/* forodec(tag, n, tau, dold, dnew, X[n][d+1]) */ + +int forodec(short,int,double,int,int,double**); + +fint forodec_(fint*,fint*,fdouble*,fint*,fint*,fdouble*); + + +/*--------------------------------------------------------------------------*/ +/* accodec */ +/* accodec(n, tau, d, Z[n][n][d+1], B[n][n][d+1], nz[n][n]) */ + +void accodec(int,double,int,double***,double***,short**); + +fint accodec_(fint*,fdouble*,fint*,fdouble*,fdouble*); + + +/****************************************************************************/ +/* THAT'S ALL */ +#ifdef __cplusplus +} +#endif + +/*--------------------------------------------------------------------------*/ +/* automatic include */ +#include "interfaces.h" + +#endif + diff --git a/adol-c/SRC/DRIVERS/odedriversC.C b/adol-c/SRC/DRIVERS/odedriversC.C new file mode 100644 index 0000000..2880939 --- /dev/null +++ b/adol-c/SRC/DRIVERS/odedriversC.C @@ -0,0 +1,115 @@ +#define _ODEDRIVERSC_CPP_ +#define _ADOLC_SRC_ +/* + ------------------------------------------------------------------------ + File odedriversC.C of ADOL-C version 1.8.0 as of Nov/30/98 + ------------------------------------------------------------------------ + Easy to use drivers for ordinary differential equations (ODE) + (Implementation of C++ callable interfaces). + + Last changes: + 981130 olvo: newly created from odedrivers.c + + ------------------------------------------------------------------------ +*/ + + +/****************************************************************************/ +/* INCLUDES */ +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" /* Users Parameters */ +#include "odedrivers.h" + + +/****************************************************************************/ +/* DRIVERS FOR ODEs, overloaded calls */ + +/*--------------------------------------------------------------------------*/ +/* forode */ +/* */ +int forode( short tag, // tape identifier + int n, // space dimension + double tau, // scaling defaults to 1.0 + int dol, // previous degree defaults to zero + int deg, // New degree of consistency + double **y) // Taylor series +/* forode(tag, n, tau, dold, dnew, X[n][d+1]) */ +{ + return forodec(tag,n,tau,dol,deg,y); +} + + +/*--------------------------------------------------------------------------*/ +/* forode */ +/* the scaling tau defaults to 1 */ +/* */ +int forode( short tag, int n, double tau, int deg, double **y) +/* forode(tag, n, tau, deg, X[n][d+1]) */ +{ + /*** Default for previous degree is zero, do things from scratch ***/ + int zero = 0; + return forodec(tag, n, tau, zero, deg, y); +} + + +/*--------------------------------------------------------------------------*/ +/* forode */ +/* previous order defaults to 0 */ +/* */ +int forode(short tag, int n, int dol, int deg, double** y) +/* forode(tag, n, dold, dnew, X[n][d+1]) */ +{ + /*** Default for scaling is 1.0 *****/ + double tau = 1.0; + return forodec(tag, n, tau, dol, deg, y); +} + + +/*--------------------------------------------------------------------------*/ +/* forode */ +/* both tau and dold default */ +/* */ +int forode(short tag, int n, int deg, double** y) +/* forode(tag, n, deg, X[n][d+1]) */ +{ + /*** Combination of both previous defaults ******/ + double tau = 1.0; + return forode(tag, n, tau, deg, y); +} + + +/*--------------------------------------------------------------------------*/ +/* accode */ +/* */ +void accode(int n, // space dimension + double tau, // scaling defaults to 1.0 + int deg, // highest degree + double ***A, // input tensor of "partial" Jacobians + double ***B, // output tensor of "total" Jacobians + short **nonzero ) // optional sparsity characterization +/* accode(n, tau, d, Z[n][n][d+1], B[n][n][d+1], nz[n][n]) */ +{ + accodec(n,tau,deg,A,B,nonzero); +} + + +/*--------------------------------------------------------------------------*/ +/* accode */ +/* scaling defaults to 1 */ +void accode(int n, // space dimension + int deg, // highest degree + double ***A, // input tensor of "partial" Jacobians + double ***B, // output tensor of "total" Jacobians + short **nonzero ) // optional sparsity characterization +/* accode(n, d, Z[n][n][d+1], B[n][n][d+1], nz[n][n]) */ +{ + + double tau = 1.0; + accodec(n,tau,deg,A,B,nonzero); +} + + +/****************************************************************************/ +/* THAT'S ALL */ +#undef _ADOLC_SRC_ +#undef _ODEDRIVERSC_CPP_ diff --git a/adol-c/SRC/DRIVERS/odedriversf.c b/adol-c/SRC/DRIVERS/odedriversf.c new file mode 100644 index 0000000..70cbe05 --- /dev/null +++ b/adol-c/SRC/DRIVERS/odedriversf.c @@ -0,0 +1,94 @@ +#define _ODEDRIVERSF_C_ +#define _ADOLC_SRC_ +/* + ------------------------------------------------------------------------ + File odedriversf.c of ADOL-C version 1.8.0 as of Nov/30/98 + ------------------------------------------------------------------------ + Easy to use drivers for ordinary differential equations (ODE) + (Implementation of the Fortran callable C interfaces). + + Last changes: + 981130 olvo: newly created from driversc.c + + ------------------------------------------------------------------------ +*/ + + +/****************************************************************************/ +/* INCLUDES */ +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" /* Users Parameters */ +#include "odedrivers.h" +#include "interfaces.h" +#include "adalloc.h" +#include "fortutils.h" + +#include +#include + +#ifdef __cplusplus +#include +extern "C" { +#endif + +/****************************************************************************/ +/* DRIVERS FOR ODEs */ + +/*--------------------------------------------------------------------------*/ +/* forodec */ +/* forodec(tag, n, tau, dold, dnew, X[n][d+1]) */ + +fint forodec_(fint* ftag, /* tape identifier */ + fint* fn, /* space dimension */ + fdouble* ftau, /* scaling defaults to 1.0 */ + fint* fdol, /* previous degree defaults to zero */ + fint* fdeg, /* New degree of consistency */ + fdouble* fy) /* Taylor series */ +{ + int rc= -1; + int tag=*ftag, n=*fn, dol=*fdol, deg=*fdeg; + int i; + double tau=*ftau; + double** Y = myalloc2(n,deg+1); + for(i=0;i jac_solv + 980814 olvo: integral constant expressions in + arrays (ANSI-C) + 980806 walther: (1) access to tensors + (2) seems to be finished + 980804 olvo/walther: debugging --> finished? + + ------------------------------------------------------------- +*/ + +/****************************************************************************/ +/* INCLUDES */ +#include "dvlparms.h" +#include "usrparms.h" +#include "taylor.h" +#include "interfaces.h" +#include "adalloc.h" + +#include +#include + +#ifdef __cplusplus +#include +extern "C" { +#endif + + +/****************************************************************************/ +/* MACROS */ +#define compsize > +#define mindec(a,b) if ((a) > (b)) (a) = (b) + + +/****************************************************************************/ +/* STRUCT ITEM */ +struct item { + int a; /* address in array of derivatives */ + int b; /* absolute value of the correspondig multiindex i */ + double c; /* value of the coefficient c_{i,j} */ + struct item *next; /* next item */ + }; + + +/****************************************************************************/ +/* DEALLOCATE COEFFLIST */ +void freecoefflist( int dim, struct item *coeff_list ) +{ int i; + struct item *ptr1; + struct item *ptr2; + + for (i=0; inext; + while (ptr1 != NULL) + { ptr2 = ptr1->next; + free((char *) ptr1); + ptr1 = ptr2; + } + } +} + + +/****************************************************************************/ +/* ALLOCATE/DEALLOCATE COEFFLIST */ +double* tensoriglob; + +/*--------------------------------------------------------------------------*/ +/* Allcoate space for symmetric derivative tensors + of up to order d in n variables, derivatives are */ +void* tensorpoint( int n, int d ) +{ int i; + void* t; + + if (d == 1) + { t = (void*) tensoriglob; + tensoriglob += n+1; + } + else + { t = (void*) malloc((n+1)*sizeof(void*)); + for (i=0; i<=n; i++) + ((void**)t)[i] = (void*) tensorpoint(i,d-1); + } + return t; +} + +/*--------------------------------------------------------------------------*/ +void** tensorsetup( int m, int n, int d, double** tensorig ) +{ int i; + void** t = (void**) malloc(m*sizeof(void*)); + + for (i=0; i 2) + for(i=0;i<=n;i++) + { t = tensor[i]; + freetensorpoint(i,d-1,(double **) t); + free((char *) t); + } +} + +/*--------------------------------------------------------------------------*/ +void freetensor( int m, int n, int d, double** tensor ) +{ int i; + double* t; + + for (i=0; i=0; j--) + jm_it[j] = jm_it[j] + jm_it[j+1]/(p+1); + im[d-m] = jm_it[0]; + for (j=1; j p) + jm_it[j] = jm_it[j-1]; + im[d-m+j] = jm_it[j]; + } + add = address(d,im); + convert(p,d,im,multi[i]); + multi[i][p]=add; + } + free((char*) im); + free((char*) jm_it); +} + + +/****************************************************************************/ +/* EVALUATE COEFFICIENTS */ +void coeff( int p, int d, struct item *coeff_list ) +{ int m,i,ii,j,k,kk,l,dim,dimi,diml,q; + int ***multi; /* multiindex */ + double d_real; + double **bin_coeff; + double *factor; + double addend, rem, coeffpart1, coeffpart2; + struct item **ptr; + + dim = binomi(p+d-1,d); + dimi = binomi(p+d,d); + factor = (double *) malloc(sizeof(double)*dim); + bin_coeff = (double **) malloc(sizeof(double*)*dim); + ptr = (struct item **) malloc(sizeof(struct item*)*dim); + + /* generate all multiindices i with 0 <= |i| <= d and + store them in multi */ + + multi = (int ***) malloc((d+2)*sizeof(int**)); + d_real = d; + for (m=1; m<=d; m++) + { dim = binomi(p+m-1,m); + multi[m] = (int **) malloc(dim*sizeof(int*)); + for(j=0; j multi[l][k][p] ) + { /* else: k > i --> hence addend = 0 */ + addend = 1; + for (kk=0; kknext = (struct item *) malloc(sizeof(struct item)); + ptr[m] = ptr[m]->next; + } + ptr[m]->a = multi[i][ii][p]; + ptr[m]->b = i; + ptr[m]->c = factor[m]; + factor[m] = 0; + } + } + } + } /* end for-loop over all multiindices i */ + for (m=0; mnext = NULL; + for (m=1; m<=d; m++) + { dim = binomi(p+m-1,m); + for(j=0; jv) + { v=fabs(J[RI[i]][CI[j]]); + rIdx=i; cIdx=j; + } + if (ZERO > v) + { fprintf(DIAG_OUT, + "Error:LUFactorisation(..): no Pivot in step %d (%le)\n",k+1,v); + return -(k+1); + } + /* row and column change resp. */ + if (rIdx > k) + { h=RI[k]; + RI[k]=RI[rIdx]; + RI[rIdx]=h; + } + if (cIdx > k) + { h=CI[k]; + CI[k]=CI[cIdx]; + CI[cIdx]=h; + } + /* Factorisation step */ + for (i=k+1; i=0; i--) + { b[CI[i]]=tmpZ[i]; + for (j=i+1; j 1) + dd[i+1] = (int)ceil(dd[i]*0.5); + bd = i+1; + } + if (cgd == 0) + for (i=0; i 0) + { di = dd[ii-1]-1; + Di = dd[ii-1]-dd[ii]-1; + mindec(rc,hos_forward(tag,n,n,di,Di+1,xold,Xhelp,w,W)); + mindec(rc,hov_reverse(tag,n,n,Di,n,I,A,nonzero)); + da = dd[ii]; + for (l=da; l1) + { Aij = A[i][j]; + Xj = X[j]+l; + for (q=da; q 0) + { if ((d != dold) || (p != pold)) + { if (pold) + { /* olvo 980728 */ + dim = binomi(pold+dold-1,dold); + freecoefflist(dim,coeff_list); + free((char*) coeff_list); + } + dim = binomi(p+d-1,d); + coeff_list = (struct item *) malloc(sizeof(struct item)*dim); + coeff(p,d, coeff_list); + dold = d; + pold = p; + } + jm = (int *)malloc(sizeof(int)*p); + X = myalloc2(n,d+1); + Y = myalloc2(n,d+1); + for (i=0; ia] += X[j][ptr->b]*ptr->c; + ptr = ptr->next; + } while (ptr != NULL); + } + } + else + { for (i=0; i=0; j--) + it[j] = it[j] + it[j+1]/(p+1); + for (j=1; j p) it[j] = it[j-1]; + convert(p,d,it,jm); + multma2vec1(n,p,d,Y,S,jm); /* Store S*jm in Y */ + mindec(rc,inverse_Taylor_prop(tag,n,d,Y,X)); + if (rc == -3) + return -3; + ptr = &coeff_list[i]; + do + { for(j=0;ja] += X[j][ptr->b]*ptr->c; + ptr = ptr->next; + } while (ptr != NULL); + } + } + free((char*) jm); + free((char*) *X); free((char*) X); + free((char*) *Y); free((char*) Y); + } + for(i=0;ia] += Y[0][j][k]*ptr[k]->c; + ptr[k] = ptr[k]->next; + } while (ptr[k] != NULL); + if (dim-i < bd) + bd = dim-i-1; + ctr = 0; + } + } + } + else + { X = myalloc3(n,bd,d); + Y = myalloc3(m,bd,d); + ctr = 0; + for (i=0; i=0; j--) + it[j] = it[j] + it[j+1]/(p+1); + for (j=1; j p) + it[j] = it[j-1]; + convert(p,d,it,jm[ctr]); + ptr[ctr] = &coeff_list[i]; + if (ctr < bd-1) + ctr += 1; + else + { multma3vec2(n,p,d,bd,X,S,jm); + mindec(rc,hov_forward(tag,m,n,d,bd,x,X,y,Y)); + for (k=0; ka] += Y[j][k][ptr[k]->b-1]*ptr[k]->c; + ptr[k] = ptr[k]->next; + } while (ptr[k] != NULL); + if (dim-i < bd) + bd = dim-i-1; + ctr = 0; + } + } + } + for (i=0; i max) + max = multi[i]; + im[i] = 0; + } + for (i=0; i max) + max = multi[j]; + } + } + add = address(d,im); + for (i=0; i jac_solv + 980806 walther: cleanup for tensors + 980804 walther: new access to tensors + + ------------------------------------------------------------- +*/ + +/****************************************************************************/ +/****************************************************************************/ +/****************************************************************************/ +/* PUBLIC EXPORTS ONLY */ + +#ifdef __cplusplus +/****************************************************************************/ +/****************************************************************************/ +/* No C++ THINGS */ + + +/****************************************************************************/ +/****************************************************************************/ +/* Now the C THINGS */ +extern "C" { +#endif + + +/****************************************************************************/ +/* TENSOR EVALUATIONS */ + +/*--------------------------------------------------------------------------*/ +/* tensor_eval(tag,m,n,d,p,x[n],tensor[m][dim],S[n][p]) + with dim = ((p+d) over d) */ +int tensor_eval(int TAG, int m, int n, int d, int p, double *x, + double **tensor, double **S); + +/*--------------------------------------------------------------------------*/ +/* inverse_tensor_eval(tag,n,d,p,x,tensor[n][dim],S[n][p]) + with dim = ((p+d) over d) */ +int inverse_tensor_eval(int tag, int n, int d, int p, double *x, + double **tensor, double **S); + +/*--------------------------------------------------------------------------*/ +/* inverse_Taylor_prop(tag,n,d,Y[n][d+1],X[n][d+1]) */ +int inverse_Taylor_prop(unsigned short tag, int n, int d, + double** Y, double** X); + + +/****************************************************************************/ +/* ACCESS TO TENSOR VALUES */ + +/*--------------------------------------------------------------------------*/ +/* tensor_value(d,m,y[m],tensori[m][dim],multi[d]) + with dim = ((p+d) over d) */ +void tensor_value(int d, int m, double *y, double **tensor, int *multi); + +/*--------------------------------------------------------------------------*/ +/* void** tensorsetup(m,p,d,tensorig) */ +void** tensorsetup(int m, int p, int d, double** tensorig); + +/*--------------------------------------------------------------------------*/ +/* void freetensor(m,p,d,tensor) */ +void freetensor(int m, int p, int d, double** tensor); + +/*--------------------------------------------------------------------------*/ +/* int address(d, im[d]) */ +int address(int d, int* im); + + +/****************************************************************************/ +/* UTILS */ + +/*--------------------------------------------------------------------------*/ +/* int binomi(a,b) ---> binomial coefficient to compute tensor dimension */ +int binomi(int a, int b); + +/*--------------------------------------------------------------------------*/ +/* jac_solv(tag,n,x,b,sparse,mode) */ +int jac_solv(unsigned short tag, int n, double* x, double* b, + unsigned short sparse, unsigned short mode); + + +/****************************************************************************/ +/* THAT'S ALL */ +#ifdef __cplusplus +} +#endif + +#endif + + + + + + + + + + + + diff --git a/adol-c/SRC/README.SRC b/adol-c/SRC/README.SRC new file mode 100644 index 0000000..e40b3c0 --- /dev/null +++ b/adol-c/SRC/README.SRC @@ -0,0 +1,111 @@ +-------------------------------------------------------------- +README.SRC ADOL-C version 1.8.x as of Dec/01/98 +-------------------------------------------------------------- + +This directory, i.e. $(ADOLC_DIR)/SRC, contains all source +files necessary to create the ADOL-C library libad.a. +The library routines are prototyped in appropriate header +files which can be included in the user source code. + +-------------------------------------------------------------- +CONTENTS OF THE DIRECTORY + +The correctly installed source consists of the following files +partially placed in subdirectories; the marked (!) header +files are of interest for the ADOL-C user: + +! adalloc.h ! adolc.h ! adouble.h ! adutils.h +! adutilsc.h ! avector.h convolut.h dvlparms.h + fortutils.h ! interfaces.h oplate.h ! taputil.h + tayutil.h ! usrparms.h + + + adallocc.c adallocC.C adouble.C avector.C + convolut.c fo_rev.c fortutils.c ho_rev.c + interfacesC.C interfacesf.c taputilc.c taputilC.C + tayutilc.c tayutilC.C uni5_for.c + + + README.SRC (this file) + + subdirectory DRIVERS (drivers for optimization, nonlinear + equations, and ODEs; drivers for + evaluation of higher order derivative + tensors and inverse/impicit function + differentiation ) + + ! drivers.h ! odedrivers.h ! taylor.h + + driversc.c driversf.c odedriversc.c + odedriversf.c odedriversC.C taylor.c + + subdirectory SPARSE (utilities for exploration of sparsity) + + ! jacutils.h ! sparse.h + + jacutils.c int_for.c int_rev.c + sparsec.c sparseC.C + + subdirectory TAPEDOC (utility for exploration of "small" + tapes [--> opcodes] destined for + ADOL-C developers) + + ! tapedoc.h + + tapedoc.c + + +NOTE: While creating the library not only object files but + also some tempory C files will be generated and placed + here. + +-------------------------------------------------------------- +OBTAINING THE MAKEFILE + +Calling the installation script + + make install + +from directory $(ADOLC_DIR)/INS will provide the file + + makefile + +to compile all files and to create the library libad.a. +(See $(ADOLC_DIR)/INS/README.INS for details.) + +-------------------------------------------------------------- +COMPILING & LINKING THE LIBRARY libad.a + +Just call + + make + +to compile all files and create the library libad.a. + +-------------------------------------------------------------- +CLEAN UP + +Calling + + make clean + +deletes the generated object files and tempory C files, +which can be removed after creating the library. To delete +all generated files including the library libad.a itself +call + + make cleanall + +-------------------------------------------------------------- + + + + + + + + + + + + diff --git a/adol-c/SRC/SPARSE/int_for.c b/adol-c/SRC/SPARSE/int_for.c new file mode 100644 index 0000000..7387c44 --- /dev/null +++ b/adol-c/SRC/SPARSE/int_for.c @@ -0,0 +1,2099 @@ +#define _INT_FOR_C_ +#define _ADOLC_SRC_ +/* + ---------------------------------------------------------------- + File int_for.c of ADOL-C version 1.8.7 as of Mar/10/2000 + ---------------------------------------------------------------- + Contains the routines : + + int_forward_tight, define _INT_FOR_TIGHT_ + (first-order-vector forward mode for bit patterns, + tight version = basepoint check, more precize) + + int_forward_safe define _INT_FOR_SAFE_ + (first-order-vector forward mode for bit patterns, + safe version, no basepoint check, return always 3 ) + + Attention : no proper subscript handling in the safe version ! + + Last changed : + 20000310 olvo (1) better error messages for discontinuity + (2) removed trigraphs stuff + 20000214 olvo new op_codes 'eq_plus_prod' and 'eq_min_prod' + for y += x1 * x2 + and y -= x1 * x2 + 990308 christo bit patterns : + unsigned int -> unsigned long int + 981130 olvo last check (includes etc.) + 981113 christo valuepoint may be NULL, check + 980930 olvo (1) new: locint checkSize; int flag; + unsigned int *TresOP + (2) new: static unsigned int Ttemp; + (3) new macros TQO* + (4) changed strategy to allow reflexive + - eq_mult_av_a, dot_av_av, mult_a_av, + div_av_a + 980925 olvo allow reflexive operations for + - cond_assign, cond_assign_s + 980924 olvo deleted all int_* opcodes + 980923 olvo updated all changes from uni5_for.c + from 980915 til 980923 + (sin_op, cos_op, min_op, abs_op) + 980917 olvo/christo macros + 980915 christo new comments + 980820 olvo new comparison strategy + + ---------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/* MACROS */ + +/*--------------------------------------------------------------------------*/ +#ifdef _INT_FOR_TIGHT_ +#define GENERATED_FILENAME "int_forward_t" +#define _TIGHT_ +#undef _SAFE_ + +/*--------------------------------------------------------------------------*/ +#elif _INT_FOR_SAFE_ +#define GENERATED_FILENAME "int_forward_s" +#undef _TIGHT_ +#define _SAFE_ + +#else +#error Error ! Define [_INT_FOR_SAFE_ | _INT_FOR_TIGHT_] +#endif +/*--------------------------------------------------------------------------*/ + +#define ARGUMENT(indexi,l,i) argument[indexi][l] +#define TAYLORS(indexd,l,i) taylors[indexd][l] + + +/*--------------------------------------------------------------------------*/ +/* access to variables */ + +#define TRES *Tres +#define TARG *Targ +#define TARG1 *Targ1 +#define TARG2 *Targ2 +#define TQO *Tqo + +#define TRES_INC *Tres++ +#define TARG_INC *Targ++ +#define TARG1_INC *Targ1++ +#define TARG2_INC *Targ2++ +#define TQO_INC *Tqo++ + +#define TRES_DEC *Tres-- +#define TARG_DEC *Targ-- +#define TARG1_DEC *Targ1-- +#define TARG2_DEC *Targ2-- +#define TQO_DEC *Tqo-- + +#define TRES_FOINC *Tres++ +#define TARG_FOINC *Targ++ +#define TARG1_FOINC *Targ1++ +#define TARG2_FOINC *Targ2++ +#define TQO_FOINC *Tqo++ + +#define TRES_FODEC *Tres-- +#define TARG_FODEC *Targ-- +#define TARG1_FODEC *Targ1-- +#define TARG2_FODEC *Targ2-- +#define TQO_FODEC *Tqo-- + + +#define ASSIGN_T(a,b) a = b; + + +/*--------------------------------------------------------------------------*/ +/* loop stuff */ +#define FOR_0_LE_l_LT_p for (l=0; l=0; l--) + + +#define FOR_0_LE_l_LT_pk for (l=0; l (b)) (a) = (b) + +/* END Macros */ + + +/****************************************************************************/ +/* NECESSARY INCLUDES */ +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" /* Users Parameters */ +#include "jacutils.h" +#include "oplate.h" +#include "adalloc.h" +#include "taputil.h" +#include "tayutil.h" + +#include +#include + +#ifdef __cplusplus +#include +extern "C" { +#endif + +/****************************************************************************/ +/* NOW THE CODE */ + +/*--------------------------------------------------------------------------*/ +/* Local Static Variables */ +static short tag; + +static int for_location_cnt; +static int dep_cnt; +static int ind_cnt; + + +#ifdef _INT_FOR_TIGHT_ +/****************************************************************************/ +/* First Order Vector version of the forward mode for bit patterns, tight */ +/****************************************************************************/ +int int_forward_tight( + short tnum, /* tape id */ + int depcheck, /* consistency chk on # of dependents */ + int indcheck, /* consistency chk on # of independents */ + int p, /* # of taylor series, bit pattern */ + double *basepoint, /* independent variable values (in)*/ + unsigned long int **argument, /* Taylor coeff. (in)*/ + double *valuepoint, /* dependent variable values (out)*/ + unsigned long int **taylors) /* matrix of coefficient vectors(out)*/ + +/* int_forward_tight( tag, m, n, p, x[n], X[n][p], y[m], Y[m][p]), + + nBV = number of Boolean Vectors to be packed + (see Chapter Dependence Analysis, ADOL-C Documentation) + bits_per_long = 8*sizeof(unsigned long int) + p = nBV / bits_per_long + ( (nBV % bits_per_long) != 0 ) + + The order of the indices in argument and taylors is [var][taylor] + + For the full Jacobian matrix set + p = indep / bits_per_long + ((indep % bits_per_long) != 0) + and pass a bit pattern version of the identity matrix as an argument */ + + +#elif _INT_FOR_SAFE_ +/****************************************************************************/ +/* First Order Vector version of the forward mode, bit pattern, safe */ +/****************************************************************************/ +int int_forward_safe( + short tnum, /* tape id */ + int depcheck, /* consistency chk on # of dependents */ + int indcheck, /* consistency chk on # of independents */ + int p, /* # of taylor series, bit pattern */ + unsigned long int **argument, /* Taylor coeff. (in)*/ + unsigned long int **taylors) /* matrix of coefficient vectors (out)*/ + +/* int_forward_tight( tag, m, n, p, X[n][p], Y[m][p]), + + nBV = number of Boolean Vectors to be packed + (see Chapter Dependence Analysis, ADOL-C Documentation) + bits_per_long = 8*sizeof(unsigned long int) + p = nBV / bits_per_long + ( (nBV % bits_per_long) != 0 ) + + The order of the indices in argument and taylors is [var][taylor] + + For the full Jacobian matrix set + p = indep / bits_per_long + ((indep % bits_per_long) != 0) + and pass a bit pattern version of the identity matrix as an argument */ + +#endif + +{ +/****************************************************************************/ +/* ALL VARIABLES */ + unsigned char operation; /* operation code */ + int tape_stats[11]; /* tape stats */ + int ret_c =3; /* return value */ + + locint size = 0; + locint res = 0; + locint arg = 0; + locint arg1 = 0; + locint arg2 = 0; + locint checkSize; + +#ifdef _TIGHT_ + double coval = 0, *d = 0; +#endif /* _TIGHT_ */ + + int indexi = 0, indexd = 0; + + /* loop indices */ + int i, j, l, ls; + + /* other necessary variables */ + double r0, x, y; + int buffer, even, flag; + static int fax, kax, pax; + + /* Taylor stuff */ +#ifdef _TIGHT_ + static double *T0; +#endif /* _TIGHT_ */ + + static unsigned long int **T; + static unsigned long int *Ttemp; + + unsigned long int *Tres, *Targ, *Targ1, *Targ2, *Tqo; + unsigned long int *TresOP, *Targ1OP, *Targ2OP; + unsigned long int T0temp; +#define T0res T0temp + + +#ifdef DEBUG +/****************************************************************************/ +/* DEBUG MESSAGES */ + fprintf(DIAG_OUT,"Call of %s(..) with tag: %d, n: %d, m %d,\n", + GENERATED_FILENAME, tnum, indcheck, depcheck); + fprintf(DIAG_OUT," p: %d\n\n",p); + +#endif + + +/****************************************************************************/ +/* INITs */ + +/* Set up stuff for the tape */ + tag = tnum; /*tag is global which specifies which tape to look at */ + + tapestats(tag,tape_stats); + ind_cnt = tape_stats[0]; + dep_cnt = tape_stats[1]; + for_location_cnt = tape_stats[2]; + buffer = tape_stats[4]; + + set_buf_size(buffer); + + if ((depcheck != dep_cnt)||(indcheck != ind_cnt)) + { fprintf(DIAG_OUT,"ADOL-C error: forward sweep on tape %d aborted!\n",tag); + fprintf(DIAG_OUT,"Number of dependent and/or independent variables passed" + " to forward is\ninconsistant with number" + " recorded on tape %d \n",tag); + exit (-1); + } + + +/****************************************************************************/ +/* MEMORY ALLOCATION */ + +/*--------------------------------------------------------------------------*/ + + if (p compsize pax || for_location_cnt compsize fax) + { if ( pax || fax ) + { +#ifdef _TIGHT_ + free((char*) T0); +#endif /* _TIGHT_ */ + free((char*) *T); free((char*) T); + free((char*) Ttemp); + } +#ifdef _TIGHT_ + T0= myalloc1(for_location_cnt); +#endif /* _TIGHT_ */ + T = myalloc2_ulong(for_location_cnt,p); + Ttemp = myalloc1_ulong(p); + pax = p; + fax = for_location_cnt; + } + + +/****************************************************************************/ +/* FORWARD SWEEP */ + + /* Initialize the Forward Sweep */ + init_for_sweep(tag); + + operation=get_op_f(); + while (operation !=end_of_tape) + { switch (operation){ + + +/****************************************************************************/ +/* MARKERS */ + +/*--------------------------------------------------------------------------*/ + case end_of_op: /* end_of_op */ + get_op_block_f(); + operation=get_op_f(); + /* Skip next operation, it's another end_of_op */ + break; + +/*--------------------------------------------------------------------------*/ + case end_of_int: /* end_of_int */ + get_loc_block_f(); + break; + +/*--------------------------------------------------------------------------*/ + case end_of_val: /* end_of_val */ +#ifdef _TIGHT_ + get_val_block_f(); +#endif /* _TIGHT_ */ + break; +/*--------------------------------------------------------------------------*/ + case start_of_tape: /* start_of_tape */ + case end_of_tape: /* end_of_tape */ + break; + + +/****************************************************************************/ +/* COMPARISON */ + +/*--------------------------------------------------------------------------*/ + case eq_zero: /* eq_zero */ + arg = get_locint_f(); + +#ifdef _TIGHT_ + if (T0[arg] != 0) + { fprintf(DIAG_OUT, + "ADOL-C Warning: Branch switch detected in comparison " + "(operator eq_zero).\n" + "Forward sweep aborted! Retaping recommended!\n"); + end_sweep(); + return (-1); + } + ret_c = 0; +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case neq_zero: /* neq_zero */ + arg = get_locint_f(); + +#ifdef _TIGHT_ + if (T0[arg] == 0) + { fprintf(DIAG_OUT, + "ADOL-C Warning: Branch switch detected in comparison " + "(operator neq_zero).\n" + "Forward sweep aborted! Retaping recommended!\n"); + end_sweep(); + return (-1); + } +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case le_zero: /* le_zero */ + arg = get_locint_f(); + +#ifdef _TIGHT_ + if (T0[arg] > 0) + { fprintf(DIAG_OUT, + "ADOL-C Warning: Branch switch detected in comparison " + "(operator le_zero).\n" + "Forward sweep aborted! Retaping recommended!\n"); + end_sweep(); + return (-1); + } + if (T0[arg] == 0) + ret_c = 0; +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case gt_zero: /* gt_zero */ + arg = get_locint_f(); + +#ifdef _TIGHT_ + if (T0[arg] <= 0) + { fprintf(DIAG_OUT, + "ADOL-C Warning: Branch switch detected in comparison " + "(operator gt_zero).\n" + "Forward sweep aborted! Retaping recommended!\n"); + end_sweep(); + return (-1); + } +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case ge_zero: /* ge_zero */ + arg = get_locint_f(); + +#ifdef _TIGHT_ + if (T0[arg] < 0) + { fprintf(DIAG_OUT, + "ADOL-C Warning: Branch switch detected in comparison " + "(operator ge_zero).\n" + "Forward sweep aborted! Retaping recommended!\n"); + end_sweep(); + return (-1); + } + if (T0[arg] == 0) + ret_c = 0; +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case lt_zero: /* lt_zero */ + arg = get_locint_f(); + +#ifdef _TIGHT_ + if (T0[arg] >= 0) + { fprintf(DIAG_OUT, + "ADOL-C Warning: Branch switch detected in comparison " + "(operator lt_zero).\n" + "Forward sweep aborted! Retaping recommended!\n"); + end_sweep(); + return (-1); + } +#endif /* _TIGHT_ */ + break; + + +/****************************************************************************/ +/* ASSIGNMENTS */ + +/*--------------------------------------------------------------------------*/ + case assign_a: /* assign an adouble variable an assign_a */ + /* adouble value. (=) */ + arg = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = T0[arg]; +#endif /* _TIGHT_ */ + + ASSIGN_T(Targ,T[arg]) + ASSIGN_T(Tres,T[res]) + + FOR_0_LE_l_LT_pk + TRES_INC = TARG_INC; + + break; + +/*--------------------------------------------------------------------------*/ + case assign_d: /* assign an adouble variable a assign_d */ + /* double value. (=) */ + res = get_locint_f(); + +#ifdef _TIGHT_ + coval = get_val_f(); + + T0[res] = coval; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + + FOR_0_LE_l_LT_pk + TRES_INC = 0; + + + break; + +/*--------------------------------------------------------------------------*/ + case assign_d_zero: /* assign an adouble variable a assign_d_zero */ + /* double value. (0) (=) */ + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = 0.0; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + + FOR_0_LE_l_LT_pk + TRES_INC = 0; + + + break; + +/*--------------------------------------------------------------------------*/ + case assign_d_one: /* assign an adouble variable a assign_d_one */ + /* double value. (1) (=) */ + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = 1.0; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + + FOR_0_LE_l_LT_pk + TRES_INC = 0; + + + break; + +/*--------------------------------------------------------------------------*/ + case assign_ind: /* assign an adouble variable an assign_ind */ + /* independent double value (<<=) */ + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = basepoint[indexi]; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + + FOR_0_LE_l_LT_p + TRES_INC = ARGUMENT(indexi,l,i); + + ++indexi; + break; + +/*--------------------------------------------------------------------------*/ + case assign_dep: /* assign a float variable a assign_dep */ + /* dependent adouble value. (>>=) */ + res = get_locint_f(); + +#ifdef _TIGHT_ + if ( valuepoint != NULL ) + valuepoint[indexd] = T0[res]; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + + if (taylors != 0 ) /* ??? question: why here? */ + FOR_0_LE_l_LT_p + TAYLORS(indexd,l,i) = TRES_INC; + + indexd++; + break; + + +/****************************************************************************/ +/* OPERATION + ASSIGNMENT */ + +/*--------------------------------------------------------------------------*/ + case eq_plus_d: /* Add a floating point to an eq_plus_d */ + /* adouble. (+=) */ + res = get_locint_f(); +#ifdef _TIGHT_ + coval = get_val_f(); + + T0[res] += coval; +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case eq_plus_a: /* Add an adouble to another eq_plus_a */ + /* adouble. (+=) */ + arg = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] += T0[arg]; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ, T[arg]) + + FOR_0_LE_l_LT_pk + TRES_INC |= TARG_INC; + + break; + +/*--------------------------------------------------------------------------*/ + case eq_min_d: /* Subtract a floating point from an eq_min_d */ + /* adouble. (-=) */ + res = get_locint_f(); +#ifdef _TIGHT_ + coval = get_val_f(); + + T0[res] -= coval; +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case eq_min_a: /* Subtract an adouble from another eq_min_a */ + /* adouble. (-=) */ + arg = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] -= T0[arg]; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ, T[arg]) + + FOR_0_LE_l_LT_pk + TRES_INC |= TARG_INC; + + + break; + +/*--------------------------------------------------------------------------*/ + case eq_mult_d: /* Multiply an adouble by a eq_mult_d */ + /* flaoting point. (*=) */ + res = get_locint_f(); +#ifdef _TIGHT_ + coval = get_val_f(); + + T0[res] *= coval; +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case eq_mult_a: /* Multiply one adouble by another eq_mult_a */ + /* (*=) */ + arg = get_locint_f(); + res = get_locint_f(); + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ, T[arg]) + + INC_pk_1(Tres) + INC_pk_1(Targ) + + FOR_p_GT_l_GE_0 + TRES_FODEC |= TARG_DEC; + +#ifdef _TIGHT_ + T0[res] *= T0[arg]; +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case incr_a: /* Increment an adouble incr_a */ + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res]++; +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case decr_a: /* Increment an adouble decr_a */ + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res]--; +#endif /* _TIGHT_ */ + break; + + +/****************************************************************************/ +/* BINARY OPERATIONS */ + +/*--------------------------------------------------------------------------*/ + case plus_a_a: /* : Add two adoubles. (+) plus a_a */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = T0[arg1] + T0[arg2]; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + ASSIGN_T(Targ2, T[arg2]) + + FOR_0_LE_l_LT_pk + TRES_INC = TARG1_INC | TARG2_INC; + + break; + +/*--------------------------------------------------------------------------*/ + case plus_d_a: /* Add an adouble and a double plus_d_a */ + /* (+) */ + arg = get_locint_f(); + res = get_locint_f(); +#ifdef _TIGHT_ + coval = get_val_f(); + + T0[res] = T0[arg] + coval; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ, T[arg]) + + FOR_0_LE_l_LT_pk + TRES_INC = TARG_INC; + + break; + +/*--------------------------------------------------------------------------*/ + case min_a_a: /* Subtraction of two adoubles min_a_a */ + /* (-) */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = T0[arg1] - T0[arg2]; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + ASSIGN_T(Targ2, T[arg2]) + + FOR_0_LE_l_LT_pk + TRES_INC = TARG1_INC | TARG2_INC; + + break; + +/*--------------------------------------------------------------------------*/ + case min_d_a: /* Subtract an adouble from a min_d_a */ + /* double (-) */ + arg =get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + coval = get_val_f(); + + T0[res] = coval - T0[arg]; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ, T[arg]) + + FOR_0_LE_l_LT_pk + TRES_INC = TARG_INC; + + break; + +/*--------------------------------------------------------------------------*/ + case mult_a_a: /* Multiply two adoubles (*) mult_a_a */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = T0[arg1] * T0[arg2]; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + ASSIGN_T(Targ2, T[arg2]) + + FOR_0_LE_l_LT_p + TRES_FOINC = TARG2_INC | TARG1_INC; + + break; + +/*--------------------------------------------------------------------------*/ + /* olvo 20000214: new op_code with recomputation */ + case eq_plus_prod: /* increment a product of eq_plus_prod */ + /* two adoubles (*) */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] += T0[arg1] * T0[arg2]; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + ASSIGN_T(Targ2, T[arg2]) + + FOR_0_LE_l_LT_p + TRES_FOINC |= TARG2_INC | TARG1_INC; + + break; + +/*--------------------------------------------------------------------------*/ + /* olvo 20000214: new op_code with recomputation */ + case eq_min_prod: /* decrement a product of eq_min_prod */ + /* two adoubles (*) */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] -= T0[arg1] * T0[arg2]; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + ASSIGN_T(Targ2, T[arg2]) + + FOR_0_LE_l_LT_p + TRES_FOINC |= TARG2_INC | TARG1_INC; + + break; + +/*--------------------------------------------------------------------------*/ + case mult_d_a: /* Multiply an adouble by a double mult_d_a */ + /* (*) */ + arg = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + coval = get_val_f(); + + T0[res] = T0[arg] * coval; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ, T[arg]) + + FOR_0_LE_l_LT_pk + TRES_INC = TARG_INC; + + break; + +/*--------------------------------------------------------------------------*/ + case div_a_a: /* Divide an adouble by an adouble div_a_a */ + /* (/) */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = T0[arg1] / T0[arg2]; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + ASSIGN_T(Targ2, T[arg2]) + + FOR_0_LE_l_LT_p + TRES_FOINC = TARG1_INC | TARG2_FOINC; + + break; + +/*--------------------------------------------------------------------------*/ + case div_d_a: /* Division double - adouble (/) div_d_a */ + arg = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + coval = get_val_f(); + + T0[res] = coval / T0[arg]; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ, T[arg]) + + FOR_0_LE_l_LT_p + TRES_FOINC = TARG_FOINC; + + break; + + +/****************************************************************************/ +/* SIGN OPERATIONS */ + +/*--------------------------------------------------------------------------*/ + case pos_sign_a: /* pos_sign_a */ + arg = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = T0[arg]; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ, T[arg]) + + FOR_0_LE_l_LT_pk + TRES_INC = TARG_INC; + + break; + +/*--------------------------------------------------------------------------*/ + case neg_sign_a: /* neg_sign_a */ + arg = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = -T0[arg]; +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ, T[arg]) + + FOR_0_LE_l_LT_pk + TRES_INC = TARG_INC; + + break; + + +/****************************************************************************/ +/* UNARY OPERATIONS */ + +/*--------------------------------------------------------------------------*/ + case exp_op: /* exponent operation exp_op */ + arg = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = exp(T0[arg]); +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ, T[arg]) + + FOR_0_LE_l_LT_p + TRES_FOINC = TARG_FOINC; + + break; + +/*--------------------------------------------------------------------------*/ + case sin_op: /* sine operation sin_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[arg2] = cos(T0[arg1]); + T0[res] = sin(T0[arg1]); +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + ASSIGN_T(Targ2, T[arg2]) + + FOR_0_LE_l_LT_p + { /* olvo 980923 changed order to allow x = sin(x) */ + TARG2_FOINC = TARG1; + TRES_FOINC = TARG1_FOINC; + } + + + break; + +/*--------------------------------------------------------------------------*/ + case cos_op: /* cosine operation cos_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[arg2] = sin(T0[arg1]); + T0[res] = cos(T0[arg1]); +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + ASSIGN_T(Targ2, T[arg2]) + + FOR_0_LE_l_LT_p + { /* olvo 980923 changed order to allow x = cos(x) */ + TARG2_FOINC = TARG1; + TRES_FOINC = TARG1_FOINC; + } + + break; + +/*--------------------------------------------------------------------------*/ + case atan_op: /* atan_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = atan(T0[arg1]); +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + + FOR_0_LE_l_LT_p + TRES_FOINC = TARG1_FOINC; + + break; + +/*--------------------------------------------------------------------------*/ + case asin_op: /* asin_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = asin(T0[arg1]); +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + + FOR_0_LE_l_LT_p + TRES_FOINC = TARG1_FOINC; + + break; + +/*--------------------------------------------------------------------------*/ + case acos_op: /* acos_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = acos(T0[arg1]); +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + + FOR_0_LE_l_LT_p + TRES_FOINC = TARG1_FOINC; + + break; + +#ifdef ATRIG_ERF + +/*--------------------------------------------------------------------------*/ + case asinh_op: /* asinh_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = asinh(T0[arg1]); +#endif /* _TIGHT_ */ + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + + FOR_0_LE_l_LT_p + TRES_FOINC = TARG1_FOINC; + + break; + +/*--------------------------------------------------------------------------*/ + case acosh_op: /* acosh_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = acosh(T0[arg1]); +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + + FOR_0_LE_l_LT_p + TRES_FOINC = TARG1_FOINC; + + break; + +/*--------------------------------------------------------------------------*/ + case atanh_op: /* atanh_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = atanh(T0[arg1]); +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + + FOR_0_LE_l_LT_p + TRES_FOINC = TARG1_FOINC; + + break; + +/*--------------------------------------------------------------------------*/ + case erf_op: /* erf_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = erf(T0[arg1]); +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1,T[arg1]) + + FOR_0_LE_l_LT_p + TRES_FOINC = TARG1_FOINC; + + break; + +#endif + +/*--------------------------------------------------------------------------*/ + case log_op: /* log_op */ + arg = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = log(T0[arg]); +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ, T[arg]) + + FOR_0_LE_l_LT_p + TRES_FOINC = TARG_INC; + + break; + +/*--------------------------------------------------------------------------*/ + case pow_op: /* pow_op */ + arg = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + coval = get_val_f(); + + T0[res] = pow(T0[arg], coval); +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ, T[arg]) + + FOR_0_LE_l_LT_p + TRES_FOINC = TARG_INC; + + break; + + + +/*--------------------------------------------------------------------------*/ + case sqrt_op: /* sqrt_op */ + arg = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + T0[res] = sqrt(T0[arg]); +#endif /* _TIGHT_ */ + ASSIGN_T(Targ, T[arg]) + ASSIGN_T(Tres, T[res]) + + FOR_0_LE_l_LT_p + TRES_FOINC = TARG_INC; + + break; + +/*--------------------------------------------------------------------------*/ + case gen_quad: /* gen_quad */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + if (get_val_f()!=T0[arg1]) + { fprintf(DIAG_OUT, + "ADOL-C Warning: forward sweep aborted; tape invalid!\n"); + end_sweep(); + return -2; + } + + T0[res] = get_val_f(); +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + + FOR_0_LE_l_LT_p + TRES_FOINC = TARG1_FOINC; + + break; + +/*--------------------------------------------------------------------------*/ + case min_op: /* min_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + coval = get_val_f(); + + /* olvo 980923 changed order to allow reflexive ops */ + if (T0[arg1] > T0[arg2]) + { if (coval) + MINDEC(ret_c,2); + } + else + if (T0[arg1] < T0[arg2]) + { if (!coval) + MINDEC(ret_c,2); + } + else + if (arg1 != arg2) + MINDEC(ret_c,1); +#endif /* _TIGHT_ */ + + ASSIGN_T(Targ1, T[arg1]) + ASSIGN_T(Targ2, T[arg2]) + ASSIGN_T(Tres, T[res]) + +#ifdef _TIGHT_ + Tqo = NULL; + if (T0[arg1] > T0[arg2]) + Tqo = Targ2; + else + if (T0[arg1] < T0[arg2]) + Tqo = Targ1; + + FOR_0_LE_l_LT_p + { Targ = Tqo; + if (Targ == NULL) /* e.g. T0[arg1] == T0[arg2] */ + { Targ1OP = Targ1; + Targ2OP = Targ2; + if (TARG1 > TARG2) + Targ = Targ2OP; + else + if (TARG1 < TARG2) + Targ = Targ1OP; + Targ1++; Targ2++; + if (Targ == NULL) /* e.g. both are equal */ + Targ = Targ1OP; + } + + TRES_INC = TARG_INC; + + if (Tqo) + Tqo++; + } + + T0[res] = FMIN(T0[arg1], T0[arg2]); +#endif /* _TIGHT_ */ +#ifdef _SAFE_ + TRES_INC = TARG1_INC | TARG2_INC; +#endif /* _SAFE_ */ + + break; + +/*--------------------------------------------------------------------------*/ + case abs_val: /* abs_val */ + arg = get_locint_f(); + res = get_locint_f(); + +#ifdef _TIGHT_ + coval = get_val_f(); + + /* olvo 980923 changed order to allow reflexive ops */ + + y = 0.0; + if (T0[arg] != 0.0) + if (T0[arg] < 0.0) + { if (coval) + MINDEC(ret_c,2); + y = -1.0; + } + else + { if (!coval) + MINDEC(ret_c,2); + y = 1.0; + } + +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ, T[arg]) + +#ifdef _TIGHT_ + FOR_0_LE_l_LT_p + { if ((y == 0.0) && (TARG != 0.0)) + MINDEC(ret_c,1); + + TRES_INC = TARG_INC; + } + + T0[res] = fabs(T0[arg]); +#endif /* _TIGHT_ */ +#ifdef _SAFE_ + FOR_0_LE_l_LT_p + TRES_INC = TARG_INC; +#endif /* _SAFE_ */ + break; + +/*--------------------------------------------------------------------------*/ + case ceil_op: /* ceil_op */ + arg = get_locint_f(); + res = get_locint_f(); +#ifdef _TIGHT_ + coval = get_val_f(); + + T0[res]=ceil(T0[arg]); + + if ( coval != T0[res] ) + MINDEC(ret_c,2); +#endif /* _TIGHT_ */ + ASSIGN_T(Tres, T[res]) + + FOR_0_LE_l_LT_pk + TRES_INC = 0; + + break; + +/*--------------------------------------------------------------------------*/ + case floor_op: /* Compute ceil of adouble floor_op */ + arg = get_locint_f(); + res = get_locint_f(); +#ifdef _TIGHT_ + coval = get_val_f(); + + T0[res] = floor(T0[arg]); + + if ( coval != T0[res] ) + MINDEC(ret_c,2); +#endif /* _TIGHT_ */ + + ASSIGN_T(Tres, T[res]) + + FOR_0_LE_l_LT_pk + TRES_INC = 0; + + break; + + +/****************************************************************************/ +/* CONDITIONALS */ + +/*--------------------------------------------------------------------------*/ + case cond_assign: /* cond_assign */ + arg = get_locint_f(); + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + + /* olvo 980925 changed order to allow reflexive ops */ + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + ASSIGN_T(Targ2, T[arg2]) + +#ifdef _TIGHT_ + coval = get_val_f(); + + if (T0[arg] > 0) + FOR_0_LE_l_LT_pk + TRES_INC = TARG1_INC; + else + FOR_0_LE_l_LT_pk + TRES_INC = TARG2_INC; + + if (T0[arg] > 0) + { if (coval <= 0.0) + MINDEC(ret_c,2); + T0[res] = T0[arg1]; + } + else + { if (coval > 0.0) + MINDEC(ret_c,2); + if (T0[arg] == 0) + MINDEC(ret_c,0); + T0[res] = T0[arg2]; + } +#endif /* _TIGHT_ */ + +#ifdef _SAFE_ + FOR_0_LE_l_LT_pk + TRES_INC = TARG1_INC | TARG2_INC; +#endif /* _SAFE_ */ + + break; + +/*--------------------------------------------------------------------------*/ + case cond_assign_s: /* cond_assign_s */ + arg = get_locint_f(); + arg1 = get_locint_f(); + res = get_locint_f(); + + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + + /* olvo 980925 changed order to allow reflexive ops */ +#ifdef _TIGHT_ + coval = get_val_f(); + + if (T0[arg] > 0) +#endif /* _TIGHT_ */ + FOR_0_LE_l_LT_pk + TRES_INC = TARG1_INC; + +#ifdef _TIGHT_ + if (T0[arg] > 0) + { if (coval <= 0.0) + MINDEC(ret_c,2); + T0[res] = T0[arg1]; + } + else + if (T0[arg] == 0) + MINDEC(ret_c,0); +#endif /* _TIGHT_ */ + + break; + + +/****************************************************************************/ +/* VECTOR ASSIGNMENTS */ + +/*--------------------------------------------------------------------------*/ + case assign_av: /* assign_av */ + arg = get_locint_f(); + size = get_locint_f(); + res = get_locint_f(); + + for (ls=0; ls= arg1) && (res < arg1+size)) + || ((res >= arg2) && (res < arg2+size)) ) + { ASSIGN_T(TresOP, Ttemp) + flag = 1; + } + else + { ASSIGN_T(TresOP, T[res]) + flag = 0; + } + + Tres = TresOP; + FOR_0_LE_l_LT_pk + TRES_INC = 0.0; + + for (ls=0; ls unsigned long int + 981203 olvo untransposing reverse + 981130 olvo last check (includes etc.) + 980930 olvo allow reflexive + - eq_mult_av_a, mult_a_av, div_av_a + 980925 olvo (1) allow reflexive operations for + - cond_assign, cond_assign_s + (2) new macros AQO* + 980924 olvo deleted all int_* opcodes + 980923 olvo updated all changes from fo_rev.c + from 980915 til 980923 + (div_a_a, div_d_a, pow_op, sin_op, cos_op) + 980820 olvo new comparison strategy + + ----------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/* MACROS */ + +/*--------------------------------------------------------------------------*/ +#ifdef _INT_REV_TIGHT_ +#define GENERATED_FILENAME "int_reverse_t" +#define _TIGHT_ +#undef _SAFE_ + +/*--------------------------------------------------------------------------*/ +#elif _INT_REV_SAFE_ +#define GENERATED_FILENAME "int_reverse_s" +#undef _TIGHT_ +#define _SAFE_ + +#else +#error Error ! Define [_INT_REV_SAFE_ | _INT_REV_TIGHT_] +#endif +/*--------------------------------------------------------------------------*/ + +#define RESULTS(indexi,l) results[l][indexi] +#define LAGRANGE(indexd,l) lagrange[l][indexd] + + +/*--------------------------------------------------------------------------*/ +/* access to variables */ + +#define ARES *Ares +#define AARG *Aarg +#define AARG1 *Aarg1 +#define AARG2 *Aarg2 +#define AQO *Aqo + +#define ARES_INC *Ares++ +#define AARG_INC *Aarg++ +#define AARG1_INC *Aarg1++ +#define AARG2_INC *Aarg2++ +#define AQO_INC *Aqo++ + +#define ARES_INC_O Ares++ +#define AARG_INC_O Aarg++ +#define AARG1_INC_O Aarg1++ +#define AARG2_INC_O Aarg2++ +#define AQO_INC_O Aqo++ + +#define ASSIGN_A(a,b) a = b; + +#define TRES T[res] +#define TARG T[arg] +#define TARG1 T[arg1] +#define TARG2 T[arg2] + +#define ASSIGN_T(a,b) + +/*--------------------------------------------------------------------------*/ +/* loop stuff */ + +#define FOR_0_LE_l_LT_p for (l=0; l=0; l--) + +#define FOR_0_LE_l_LT_pk1 for (l=0; l (b)) (a) = (b) + +/* END Macros */ + + +/****************************************************************************/ +/* NECESSARY INCLUDES */ +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" /* Users Parameters */ +#include "jacutils.h" +#include "oplate.h" +#include "adalloc.h" +#include "taputil.h" +#include "tayutil.h" + +#include +#include + +#ifdef __cplusplus +#include +extern "C" { +#endif + + +/****************************************************************************/ +/* NOW THE CODE */ + +/*--------------------------------------------------------------------------*/ +/* Local Static Variables */ +static short tag; + +static int rev_location_cnt; +static int dep_cnt; +static int ind_cnt; + +/****************************************************************************/ +/* First-Order Vector Reverse Pass for bit patterns. */ +/****************************************************************************/ + +#ifdef _TIGHT_ +int int_reverse_tight( +#endif /* _TIGHT_ */ +#ifdef _SAFE_ +int int_reverse_safe( +#endif /* _SAFE_ */ + short tnum, /* tape id */ + int depen, /* consistency chk on # of deps */ + int indep, /* consistency chk on # of indeps */ + int nrows, /* # of Jacobian rows being calculated q */ + unsigned long int **lagrange,/* domain weight vector[var][row](in)*/ + unsigned long int **results) /* matrix of coeff. vectors[var][row]*/ + +/* int_reverse_...( tag, m, n, q, U[q][m], Z[q][n]) + + nBV = number of Boolean Vectors to be packed + (see Chapter Dependence Analysis, ADOL-C Documentation) + bits_per_long = 8*sizeof(unsigned long int) + q = nBV / bits_per_long + ( (nBV % bits_per_long) != 0 ) + + For the full Jacobian matrix set + q = depen / bits_per_long + ((depen % bits_per_long) != 0) + and pass a bit pattern version of the identity matrix as an argument */ + +{ +/****************************************************************************/ +/* ALL VARIABLES */ + unsigned char operation; /* operation code */ + int tape_stats[11]; /* tape stats */ + int ret_c=3; /* return value */ + + locint size = 0; + locint res = 0; + locint arg = 0; + locint arg1 = 0; + locint arg2 = 0; + +#ifdef _TIGHT_ + double coval = 0, *d = 0; +#endif /* _TIGHT_ */ + + int indexi = 0, indexd = 0; + + /* loop indices */ + int i, j, l, ls; + + /* other necessary variables */ + int buffer; + static int rax, pax; + int taycheck; + int numdep,numind; + unsigned long int aTmp; + +/*--------------------------------------------------------------------------*/ + /* Taylor stuff */ + +#ifdef _TIGHT_ + static revreal *T; +#endif /* _TIGHT_ */ + +/*--------------------------------------------------------------------------*/ + /* Adjoint stuff */ + + static unsigned long int **A; + + static unsigned long int *Atemp; + unsigned long int *Ares, *Aarg, *Aarg1, *Aarg2, *Aqo; + + +/*--------------------------------------------------------------------------*/ + + /* Notice: The "q" in the interfaces is reperesented internally by "p" */ + int p = nrows; + + +#ifdef DEBUG +/****************************************************************************/ +/* DEBUG MESSAGES */ + fprintf(DIAG_OUT,"Call of %s(..) with tag: %d, n: %d, m %d,\n", + GENERATED_FILENAME, tnum, indep, depen); + fprintf(DIAG_OUT," p: %d\n\n",nrows); +#endif + + +/****************************************************************************/ +/* INITs */ + + /*------------------------------------------------------------------------*/ + /* Set up stuff for the tape */ + + tag = tnum; /*tag is global which indicates which tape to look at */ + + tapestats(tag,tape_stats); + ind_cnt = tape_stats[0]; + dep_cnt = tape_stats[1]; + rev_location_cnt = tape_stats[2]; + buffer = tape_stats[4]; + + set_buf_size(buffer); + + if ((depen != dep_cnt)||(indep != ind_cnt)) + { fprintf(DIAG_OUT,"ADOL-C error: Reverse sweep on tape %d aborted!\n",tag); + fprintf(DIAG_OUT,"Number of dependent and/or independent variables " + "passed to reverse is\ninconsistent with number " + "recorded on tape %d \n",tag); + exit (-1); + } + + indexi = ind_cnt - 1; + indexd = dep_cnt - 1; + + +/****************************************************************************/ +/* MEMORY ALLOCATION STUFF */ + + if (rev_location_cnt compsize rax || p compsize pax) + { if (rax || pax) + { free((char*) Atemp); +#ifdef _TIGHT_ + free((char*) T); +#endif /* _TIGHT_ */ + free((char*) *A); free((char*) A); + } + Atemp = myalloc1_ulong(p); +#ifdef _TIGHT_ + T = (revreal *)malloc(sizeof(revreal)*rev_location_cnt); + if (T == NULL) + { fprintf(DIAG_OUT,"ADOL-C error: cannot allocate %i bytes!\n", + sizeof(revreal)*rev_location_cnt); + exit (-1); + } +#endif /* _TIGHT_ */ + A = myalloc2_ulong(rev_location_cnt,p); + rax = rev_location_cnt; + pax = p; + } + + +/****************************************************************************/ +/* TAYLOR INITIALIZATION */ +#ifdef _TIGHT_ + + taylor_back(T,&numdep,&numind,&taycheck); + + if (taycheck < 0) + { fprintf(DIAG_OUT,"\n ADOL-C error: reverse fails because it was not" + " preceeded\nby a forward sweep with degree>0, keep=1!\n"); + exit(-2); + }; + + if((numdep != depen)||(numind != indep)) + { fprintf(DIAG_OUT, "\n ADOL-C error: reverse fails on tape %d because the" + " number of\nindependent and/or dependent variables" + " given to reverse are\ninconsistent with that of the" + " internal taylor array.\n",tag); + exit(-2); + } + +#endif /* _TIGHT_ */ +/****************************************************************************/ +/* REVERSE SWEEP */ + + /* Initialize the Reverse Sweep */ + init_rev_sweep(tag); + + operation=get_op_r(); + while (operation != start_of_tape) + { /* Switch statement to execute the operations in Reverse */ + switch (operation) { + + +/****************************************************************************/ +/* MARKERS */ + +/*--------------------------------------------------------------------------*/ + case end_of_op: /* end_of_op */ + get_op_block_r(); + operation = get_op_r(); + /* Skip next operation, it's another end_of_op */ + break; + +/*--------------------------------------------------------------------------*/ + case end_of_int: /* end_of_int */ + get_loc_block_r(); /* Get the next int block */ + break; + +/*--------------------------------------------------------------------------*/ + case end_of_val: /* end_of_val */ +#ifdef _TIGHT_ + get_val_block_r(); /* Get the next val block */ +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case start_of_tape: /* start_of_tape */ + case end_of_tape: /* end_of_tape */ + break; + + +/****************************************************************************/ +/* COMPARISON */ + +/*--------------------------------------------------------------------------*/ + case eq_zero : /* eq_zero */ + arg = get_locint_r(); + +#ifdef _TIGHT_ + ret_c = 0; +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case neq_zero : /* neq_zero */ + case gt_zero : /* gt_zero */ + case lt_zero : /* lt_zero */ + arg = get_locint_r(); + break; + +/*--------------------------------------------------------------------------*/ + case ge_zero : /* ge_zero */ + case le_zero : /* le_zero */ + arg = get_locint_r(); + +#ifdef _TIGHT_ + ASSIGN_T( Targ, T[arg]) + + if (TARG == 0) + ret_c = 0; +#endif /* _TIGHT_ */ + break; + + +/****************************************************************************/ +/* ASSIGNMENTS */ + +/*--------------------------------------------------------------------------*/ + case assign_a: /* assign an adouble variable an assign_a */ + /* adouble value. (=) */ + res = get_locint_r(); + arg = get_locint_r(); + + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + { AARG_INC |= ARES; + ARES_INC = 0; + } + +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case assign_d: /* assign an adouble variable a assign_d */ + /* double value. (=) */ + res = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); +#endif /* _TIGHT_ */ + + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + ARES_INC = 0; +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case assign_d_zero: /* assign an adouble variable a assign_d_zero */ + case assign_d_one: /* double value (0 or 1). (=) assign_d_one */ + res = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + ARES_INC = 0; + +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case assign_ind: /* assign an adouble variable an assign_ind */ + /* independent double value (<<=) */ + res = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + RESULTS(indexi,l) = ARES_INC; + +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + indexi--; + break; + +/*--------------------------------------------------------------------------*/ + case assign_dep: /* assign a float variable a assign_dep */ + /* dependent adouble value. (>>=) */ + res = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + ARES_INC = LAGRANGE(indexd,l); + + indexd--; + break; + + +/****************************************************************************/ +/* OPERATION + ASSIGNMENT */ + +/*--------------------------------------------------------------------------*/ + case eq_plus_d: /* Add a floating point to an eq_plus_d */ + /* adouble. (+=) */ + res = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); + + get_taylor(res); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case eq_plus_a: /* Add an adouble to another eq_plus_a */ + /* adouble. (+=) */ + res = get_locint_r(); + arg = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]); + + FOR_0_LE_l_LT_p + AARG_INC |= ARES_INC; + +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case eq_min_d: /* Subtract a floating point from an eq_min_d */ + /* adouble. (-=) */ + res = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); + + get_taylor(res); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case eq_min_a: /* Subtract an adouble from another eq_min_a */ + /* adouble. (-=) */ + res = get_locint_r(); + arg = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + AARG_INC |= ARES_INC; + +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case eq_mult_d: /* Multiply an adouble by a eq_mult_d */ + /* flaoting point. (*=) */ + res = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); + + get_taylor(res); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case eq_mult_a: /* Multiply one adouble by another eq_mult_a */ + /* (*=) */ + res = get_locint_r(); + arg = get_locint_r(); +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + AARG_INC |= ARES_INC; + + break; + +/*--------------------------------------------------------------------------*/ + case incr_a: /* Increment an adouble incr_a */ + case decr_a: /* Increment an adouble decr_a */ + res = get_locint_r(); + +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + break; + + +/****************************************************************************/ +/* BINARY OPERATIONS */ + +/*--------------------------------------------------------------------------*/ + case plus_a_a: /* : Add two adoubles. (+) plus a_a */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_A( Aarg2, A[arg2]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG1_INC |= aTmp; + AARG2_INC |= aTmp; + } +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case plus_d_a: /* Add an adouble and a double plus_d_a */ + /* (+) */ + res = get_locint_r(); + arg = get_locint_r(); + +#ifdef _TIGHT_ + coval = get_val_r(); +#endif /* _TIGHT_ */ + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG_INC |= aTmp; + } +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case min_a_a: /* Subtraction of two adoubles min_a_a */ + /* (-) */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_A( Aarg2, A[arg2]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG1_INC |= aTmp; + AARG2_INC |= aTmp; + } +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case min_d_a: /* Subtract an adouble from a min_d_a */ + /* double (-) */ + res = get_locint_r(); + arg = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); +#endif /* _TIGHT_ */ + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG_INC |= aTmp; + } +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case mult_a_a: /* Multiply two adoubles (*) mult_a_a */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Aarg1, A[arg1]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG2_INC |= aTmp; + AARG1_INC |= aTmp; + } + break; + +/*--------------------------------------------------------------------------*/ + /* olvo 20000214: new op_code with recomputation */ + case eq_plus_prod: /* increment a product of eq_plus_prod */ + /* two adoubles (*) */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Aarg1, A[arg1]) + +#ifdef _TIGHT_ + /* Recomputation */ + ASSIGN_T( Targ1, T[arg1]) + ASSIGN_T( Targ2, T[arg2]) + ASSIGN_T( Tres, T[res]) + + TRES -= TARG1*TARG2; +#endif /* _TIGHT_ */ + + FOR_0_LE_l_LT_p + { AARG2_INC |= ARES; + AARG1_INC |= ARES_INC; + } + break; + +/*--------------------------------------------------------------------------*/ + /* olvo 20000214: new op_code with recomputation */ + case eq_min_prod: /* decrement a product of eq_min_prod */ + /* two adoubles (*) */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Aarg1, A[arg1]) + +#ifdef _TIGHT_ + /* Recomputation */ + ASSIGN_T( Targ1, T[arg1]) + ASSIGN_T( Targ2, T[arg2]) + ASSIGN_T( Tres, T[res]) + + TRES += TARG1*TARG2; +#endif /* _TIGHT_ */ + + FOR_0_LE_l_LT_p + { AARG2_INC |= ARES; + AARG1_INC |= ARES_INC; + } + break; + +/*--------------------------------------------------------------------------*/ + case mult_d_a: /* Multiply an adouble by a double mult_d_a */ + /* (*) */ + res = get_locint_r(); + arg = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); +#endif /* _TIGHT_ */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG_INC |= aTmp; + } + +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case div_a_a: /* Divide an adouble by an adouble div_a_a */ + /* (/) */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Aarg1, A[arg1]) + + /* olvo 980923 to allow x =y/x */ +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG1_INC |= aTmp; + AARG2_INC |= aTmp; + } + break; + +/*--------------------------------------------------------------------------*/ + case div_d_a: /* Division double - adouble (/) div_d_a */ + res = get_locint_r(); + arg = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); +#endif /* _TIGHT_ */ + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + /* olvo 980923 to allow x =d/x */ +#ifdef _TIGHT_ + if (arg == res) + get_taylor(arg); +#endif /* _TIGHT_ */ + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG_INC |= aTmp; + } +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + break; + + +/****************************************************************************/ +/* SIGN OPERATIONS */ + +/*--------------------------------------------------------------------------*/ + case pos_sign_a: /* pos_sign_a */ + res = get_locint_r(); + arg = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG_INC |= aTmp; + } + +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case neg_sign_a: /* neg_sign_a */ + res = get_locint_r(); + arg = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG_INC |= aTmp; + } +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + break; + + +/****************************************************************************/ +/* UNARY OPERATIONS */ + +/*--------------------------------------------------------------------------*/ + case exp_op: /* exponent operation exp_op */ + res = get_locint_r(); + arg = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG_INC |= aTmp; + } +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case sin_op: /* sine operation sin_op */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG1_INC |= aTmp; + } + +#ifdef _TIGHT_ + /* olvo 980923 changed order to allow x = sin(x) */ + get_taylor(res); + get_taylor(arg2); /* olvo 980710 covalue */ + /* NOTE: A[arg2] should be 0 already */ +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case cos_op: /* cosine operation cos_op */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG1_INC |= aTmp; + } + +#ifdef _TIGHT_ + /* olvo 980923 changed order to allow x = cos(x) */ + get_taylor(res); + get_taylor(arg2); /* olvo 980710 covalue */ + /* NOTE A[arg2] should be 0 already */ +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case atan_op: /* atan_op */ + case asin_op: /* asin_op */ + case acos_op: /* acos_op */ + case asinh_op: /* asinh_op */ + case acosh_op: /* acosh_op */ + case atanh_op: /* atanh_op */ + case erf_op: /* erf_op */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG1_INC |= aTmp; + } + break; + +/*--------------------------------------------------------------------------*/ + case log_op: /* log_op */ + res = get_locint_r(); + arg = get_locint_r(); +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG_INC |= aTmp; + } + break; + +/*--------------------------------------------------------------------------*/ + case pow_op: /* pow_op */ + res = get_locint_r(); + arg = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); +#endif /* _TIGHT_ */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + /* olvo 980923 to allow x = pow(x,d) */ +#ifdef _TIGHT_ + if (arg == res) + get_taylor(arg); +#endif /* _TIGHT_ */ + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG_INC |= aTmp; + } +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case sqrt_op: /* sqrt_op */ + res = get_locint_r(); + arg = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG_INC |= aTmp; + } +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case gen_quad: /* gen_quad */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); + coval = get_val_r(); +#endif /* _TIGHT_ */ + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG1_INC |= aTmp; + } +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case min_op: /* min_op */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); + + get_taylor(res); +#endif /* _TIGHT_ */ + + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Ares, A[res]) +#ifdef _TIGHT_ + ASSIGN_T( Targ1, T[arg1]) + ASSIGN_T( Targ2, T[arg2]) + + if (TARG1 > TARG2) + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + if ((coval) && (aTmp)) + MINDEC(ret_c,2); + AARG2_INC |= aTmp; + } + else + if (TARG1 < TARG2) + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + if ((!coval) && (aTmp)) + MINDEC(ret_c,2); + AARG1_INC |= aTmp; + } + else + { /* both are equal */ + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG2_INC |= aTmp; + AARG1_INC |= aTmp; + } + if (arg1 != arg2) + MINDEC(ret_c,1); + } +#endif /* _TIGHT_ */ +#ifdef _SAFE_ + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG1_INC |= aTmp; + AARG2_INC |= aTmp; + } +#endif /* _SAFE_ */ + break; + +/*--------------------------------------------------------------------------*/ + case abs_val: /* abs_val */ + res = get_locint_r(); + arg = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); + + get_taylor(res); +#endif /* _TIGHT_ */ + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) +#ifdef _TIGHT_ + ASSIGN_T( Targ, T[arg]) + + if (TARG < 0.0) + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + if ((coval) && (aTmp)) + MINDEC(ret_c,2); + AARG_INC |= aTmp; + } + else + if (TARG > 0.0) + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + if ((!coval) && (aTmp)) + MINDEC(ret_c,2); + AARG_INC |= aTmp; + } + else + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + if (aTmp) + MINDEC(ret_c,1); + } +#endif /* _TIGHT_ */ +#ifdef _SAFE_ + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG_INC |= aTmp; + } +#endif /* _SAFE_ */ + break; + +/*--------------------------------------------------------------------------*/ + case ceil_op: /* ceil_op */ + res = get_locint_r(); + arg = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); + + get_taylor(res); +#endif /* _TIGHT_ */ + ASSIGN_A( Ares, A[res]) +#ifdef _TIGHT_ + ASSIGN_T( Targ, T[arg]) + + coval = (coval != ceil(TARG) ); +#endif /* _TIGHT_ */ + + FOR_0_LE_l_LT_p + { +#ifdef _TIGHT_ + if ((coval) && (ARES)) + MINDEC(ret_c,2); +#endif /* _TIGHT_ */ + ARES_INC = 0; + } + break; + +/*--------------------------------------------------------------------------*/ + case floor_op: /* floor_op */ + res = get_locint_r(); + arg = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); + + get_taylor(res); +#endif /* _TIGHT_ */ + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) +#ifdef _TIGHT_ + ASSIGN_T( Targ, T[arg]) + + coval = ( coval != floor(TARG1) ); +#endif /* _TIGHT_ */ + FOR_0_LE_l_LT_p + { +#ifdef _TIGHT_ + if ( (coval) && (ARES) ) + MINDEC(ret_c,2); +#endif /* _TIGHT_ */ + ARES_INC = 0; + } + break; + + +/****************************************************************************/ +/* CONDITIONALS */ + +/*--------------------------------------------------------------------------*/ + case cond_assign: /* cond_assign */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + arg = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); + + get_taylor(res); +#endif /* _TIGHT_ */ + + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg2, A[arg2]) +#ifdef _TIGHT_ + ASSIGN_T( Targ, T[arg]) + + /* olvo 980925 changed code a little bit */ + if (TARG > 0.0) + { if (res != arg1) + FOR_0_LE_l_LT_p + { if ((coval <= 0.0) && (ARES)) + MINDEC(ret_c,2); + AARG1_INC |= ARES; + ARES_INC = 0.0; + } + else + FOR_0_LE_l_LT_p + if ((coval <= 0.0) && (ARES_INC)) + MINDEC(ret_c,2); + } + else + { if (res != arg2) + FOR_0_LE_l_LT_p + { if ((coval <= 0.0) && (ARES)) + MINDEC(ret_c,2); + AARG2_INC |= ARES; + ARES_INC = 0.0; + } + else + FOR_0_LE_l_LT_p + if ((coval <= 0.0) && (ARES_INC)) + MINDEC(ret_c,2); + } +#endif /* _TIGHT_ */ + +#ifdef _SAFE_ + if (res != arg1) + { FOR_0_LE_l_LT_p + AARG1_INC |= ARES_INC; + ASSIGN_A( Ares, A[res]) + } + if (res != arg2) + { FOR_0_LE_l_LT_p + AARG2_INC |= ARES_INC; + ASSIGN_A( Ares, A[res]) + } + if ((res != arg1) && (res != arg2)) + FOR_0_LE_l_LT_p + ARES_INC = 0; +#endif /* _SAFE_ */ + break; + +/*--------------------------------------------------------------------------*/ + case cond_assign_s: /* cond_assign_s */ + res = get_locint_r(); + arg1 = get_locint_r(); + arg = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); + + get_taylor(res); +#endif /* _TIGHT_ */ + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_A( Ares, A[res]) +#ifdef _TIGHT_ + ASSIGN_T( Targ, T[arg]) + + /* olvo 980924 changed code a little bit */ + if (TARG > 0.0) + { if (res != arg1) + FOR_0_LE_l_LT_p + { if ((coval <= 0.0) && (ARES)) + MINDEC(ret_c,2); + AARG1_INC |= ARES; + ARES_INC = 0.0; + } + else + FOR_0_LE_l_LT_p + if ((coval <= 0.0) && (ARES_INC)) + MINDEC(ret_c,2); + } + else + if (TARG == 0.0) /* we are at the tie */ + FOR_0_LE_l_LT_p + if (ARES_INC) + MINDEC(ret_c,0); +#endif /* _TIGHT_ */ + +#ifdef _SAFE_ + if (res != arg1) + FOR_0_LE_l_LT_p + { AARG1 |= ARES; + ARES_INC = 0; + } +#endif /* _SAFE_ */ + break; + + +/****************************************************************************/ +/* VECTOR ASSIGNMENTS */ + +/*--------------------------------------------------------------------------*/ + case assign_av: /* assign_av */ + res = get_locint_r(); + size = get_locint_r(); + arg = get_locint_r(); + + res += size; + arg += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of left-hand-side */ + arg--; /* Location of right-hand-side */ + + /* code for assign_a */ + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + { AARG_INC |= ARES; + ARES_INC = 0; + } +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + } + break; + +/*--------------------------------------------------------------------------*/ + case assign_dv: /* assign_dv */ + res = get_locint_r(); + size = get_locint_r(); +#ifdef _TIGHT_ + d = get_val_v_r(size); +#endif /* _TIGHT_ */ + res += size; + + for (ls=size; ls>0; ls--) + { res--; /* Location of left-hand-side */ + + /* code for assign_d */ + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + ARES_INC = 0; +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + } + break; + +/*--------------------------------------------------------------------------*/ + case assign_indvec: /* assign_indvec */ + res = get_locint_r(); + size = get_locint_r(); + + res += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of the left-hand-side */ + + /* code for assign_ind */ + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + RESULTS(indexi,l) = ARES_INC; + indexi--; +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + } +#ifdef _TIGHT_ + reset_val_r(); +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case assign_depvec: /* assign_depvec */ + res = get_locint_r(); + size = get_locint_r(); + + res += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of the left-hand-side */ + + /* code for assign_dep */ + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + ARES_INC = LAGRANGE(indexd,l); + indexd--; + } + break; + + +/****************************************************************************/ +/* VECTOR OPERATION + ASSIGNMENT */ + +/*--------------------------------------------------------------------------*/ + case eq_plus_av: /* eq_plus_av */ + res = get_locint_r(); + size = get_locint_r(); + arg = get_locint_r(); + + res += size; + arg += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of left-hand-side */ + arg--; /* Location on right-hand-side */ + + /* code for eq_plus_a */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A (Aarg, A[arg]) + + FOR_0_LE_l_LT_p + AARG_INC |= ARES_INC; +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + } + break; + +/*--------------------------------------------------------------------------*/ + case eq_min_av: /* eq_min_av */ + res = get_locint_r(); + size = get_locint_r(); + arg = get_locint_r(); + + res += size; + arg += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of left-hand-side */ + arg--; /* Location on right-hand-side */ + + /* code for eq_min_a */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + AARG_INC |= ARES_INC; +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + } + break; + +/*--------------------------------------------------------------------------*/ + case eq_mult_av_d: /* eq_mult_av_d */ + res = get_locint_r(); + size = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); + + res += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of the left-hand-side */ + + /* code for eq_mult_d*/ + + get_taylor(res); + } +#endif /* _TIGHT_ */ + break; + +/*--------------------------------------------------------------------------*/ + case eq_mult_av_a: /* eq_mult_av_a */ + res = get_locint_r(); + size = get_locint_r(); + arg = get_locint_r(); + + /* olvo 980930 new strategy to check for overwrites + (changes computation order) */ +#ifdef _TIGHT_ + if ((arg >= res) && (arg < res+size)) + { /* FIRST compute the case: res==arg */ + /* simplified code for eq_mult_a*/ + get_taylor(arg); + } +#endif /* _TIGHT_ */ + + res += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of the left-hand-side */ + /* arg = fixed; Location on the right-hand-side */ + + if (res == arg) /* NOW skip this case */ + continue; + + /* code for eq_mult_a*/ +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + AARG_INC |= ARES_INC; + + } + break; + + +/****************************************************************************/ +/* BINARY VECTOR OPERATIONS */ + +/*--------------------------------------------------------------------------*/ + case plus_av_av: /* plus_av_av */ + res = get_locint_r(); + size = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + res += size; + arg1 += size; + arg2 += size; + for (ls=size; ls>0; ls--) + { arg2--; /* Location of var 2 */ + arg1--; /* Location of var 1 */ + res--; /* Location of result */ + + /* code for plus_a_a */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_A( Aarg2, A[arg2]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG1_INC |= aTmp; + AARG2_INC |= aTmp; + } +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + } + break; + +/*--------------------------------------------------------------------------*/ + case sub_av_av: /* sub_av_av */ + res = get_locint_r(); + size = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + res += size; + arg1 += size; + arg2 += size; + for (ls=size; ls>0; ls--) + { arg2--; /* Location of var 2 */ + arg1--; /* Location of var 1 */ + res--; /* Location of result */ + + /* code for min_a_a */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_A( Aarg2, A[arg2]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG1_INC |= aTmp; + AARG2_INC |= aTmp; + } +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + } + break; + +/*--------------------------------------------------------------------------*/ + case dot_av_av: /* dot_av_av */ + res = get_locint_r(); + size = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + + /* save Ares to Atemp */ + ASSIGN_A( Aqo, Atemp) + ASSIGN_A( Ares, A[res]) + FOR_0_LE_l_LT_p + { AQO_INC = ARES; + ARES_INC = 0; + } + + for (ls=0; ls= res) && (arg2 < res+size)) + { /* FIRST compute the case: res==arg2 */ + /* simplified code for mult_a_a */ +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Aarg1, A[arg1]) + + FOR_0_LE_l_LT_p + AARG1_INC |= AARG2_INC; + } + + res += size; + arg1 += size; + for (ls=size; ls>0; ls--) + { arg1--; /* Location of rght hnd side vectore[l] */ + res--; /* Location of the result */ + + if (res == arg2) /* NOW skip this case */ + continue; + + /* code for mult_a_a */ +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Aarg1, A[arg1]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG2_INC |= aTmp; + AARG1_INC |= aTmp; + } + } + break; + +/*--------------------------------------------------------------------------*/ + case mult_d_av: /* mult_d_av */ + res = get_locint_r(); + size = get_locint_r(); + arg = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); +#endif /* _TIGHT_ */ + + res += size; + arg += size; + for (ls=size; ls>0; ls--) + { arg--; /* Location on the right-hand-side */ + res--; /* location of the result */ + /* coval = Fixed double value */ + + /* code for mult_d_a */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG_INC |= aTmp; + } +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + } + break; + +/*--------------------------------------------------------------------------*/ + case div_av_a: /* div_av_a */ + res = get_locint_r(); + size = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + /* olvo 980930 new strategy to check for overwrites + (changes computation order) */ + if ((arg2 >= res) && (arg2 < res+size)) + { /* FIRST compute the case: res==arg2 */ + /* simplified code for div_a_a */ + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Aarg1, A[arg1]) + + FOR_0_LE_l_LT_p + AARG1_INC |= AARG2_INC; + +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + } + + res += size; + arg1 += size; + for (ls=size; ls>0; ls--) + { arg1--; /* Location of right-hand-side vector[l] */ + res--; /* Location of the result */ + + if (res == arg2) /* NOW skip this case */ + continue; + + /* code for div_a_a */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Aarg1, A[arg1]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0; + AARG1_INC |= aTmp; + AARG2_INC |= aTmp; + } +#ifdef _TIGHT_ + get_taylor(res); +#endif /* _TIGHT_ */ + } + break; + + +/****************************************************************************/ +/* SUBSCRIPTS */ + + +/*--------------------------------------------------------------------------*/ + case subscript: /* subscript */ + res = get_locint_r(); + arg1 = get_locint_r(); + arg2 = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); + + ASSIGN_T( Targ1, T[arg1]) + + arg = arg2 + (int)(TARG1); + + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + { + if (((int)(coval) != (int)(TARG1)) && (ARES)) + MINDEC(ret_c,2); + + AARG_INC |= ARES; + if (arg != res) + ARES_INC = 0; + else + ARES_INC; + } +#endif /* _TIGHT_ */ +#ifdef _SAFE_ + fprintf(DIAG_OUT,"ADOL-C fatal error in " GENERATED_FILENAME " (" + __FILE__ ") : no such operation %d\n\n" + "active subscripts are not implemented in the safe version" + " of bit pattern reverse mode\n" + , operation); + exit(-1); +#endif /* _SAFE_ */ + break; + +/*--------------------------------------------------------------------------*/ + case subscript_l: /* subscript_l */ + arg = get_locint_r(); + arg1 = get_locint_r(); + arg2 = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); + + ASSIGN_T( Targ1, T[arg1]) + + res = arg2 + (int)(TARG1); + + get_taylor(res); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + { + if (((int)(coval) != (int)(TARG1)) && (ARES)) + MINDEC(ret_c,2); + + AARG_INC |= ARES; + if(arg != res) + ARES_INC = 0; + else + ARES_INC; + } +#endif /* _TIGHT_ */ +#ifdef _SAFE_ + fprintf(DIAG_OUT,"ADOL-C fatal error in " GENERATED_FILENAME " (" + __FILE__ ") : no such operation %d\n\n" + "active subscripts are not implemented in the safe version" + " of bit pattern reverse mode\n" + , operation); + exit(-1); +#endif /* _SAFE_ */ + break; + +/*--------------------------------------------------------------------------*/ + case subscript_ld: /* subscript_ld */ + arg1 = get_locint_r(); + arg2 = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); + coval = get_val_r(); + + ASSIGN_T( Targ1, T[arg1]) + + arg = arg2 + (int)(TARG1); + + get_taylor(arg); + + if((int)(coval)!=(int)(TARG1)) + MINDEC(ret_c,2); + + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + AARG_INC = 0; +#endif /* _TIGHT_ */ +#ifdef _SAFE_ + fprintf(DIAG_OUT,"ADOL-C fatal error in " GENERATED_FILENAME " (" + __FILE__ ") : no such operation %d\n\n" + "active subscripts are not implemented in the safe version" + " of bit pattern reverse mode\n" + , operation); + exit(-1); +#endif /* _SAFE_ */ + break; + +/*--------------------------------------------------------------------------*/ + case m_subscript: /* m_subscript */ + res = get_locint_r(); + size = get_locint_r(); + arg1 = get_locint_r(); + arg2 = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); + + ASSIGN_T( Targ1, T[arg1]) + + arg = arg2 + ((int)(TARG1) + 1)*size; + + res += size; + for (ls=size; ls>0; ls--) + { res--; arg--; + + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + { + if (((int)(coval)!=(int)(TARG1)) && (ARES)) + MINDEC(ret_c,2); + + AARG_INC |= ARES; + if (arg != res) + ARES_INC = 0; + else + ARES_INC; + } + } +#endif /* _TIGHT_ */ +#ifdef _SAFE_ + fprintf(DIAG_OUT,"ADOL-C fatal error in " GENERATED_FILENAME " (" + __FILE__ ") : no such operation %d\n\n" + "active subscripts are not implemented in the safe version" + " of bit pattern reverse mode\n" + , operation); + exit(-1); +#endif /* _SAFE_ */ + break; + +/*--------------------------------------------------------------------------*/ + case m_subscript_l: /* m_subscript_l */ + arg = get_locint_r(); + size = get_locint_r(); + arg1 = get_locint_r(); + arg2 = get_locint_r(); +#ifdef _TIGHT_ + coval = get_val_r(); + + ASSIGN_T( Targ1, T[arg1]) + + res = arg2 + ((int)(TARG1) + 1)*size; + arg += size; + for (ls=size; ls>0; ls--) + { arg--; res--; + + get_taylor(res); + + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + { + if (((int)(coval) != (int)(TARG1)) && (ARES)) + MINDEC(ret_c,2); + + AARG_INC |= ARES; + if (arg != res) + ARES_INC = 0; + else + ARES_INC; + } + } +#endif /* _TIGHT_ */ +#ifdef _SAFE_ + fprintf(DIAG_OUT,"ADOL-C fatal error in " GENERATED_FILENAME " (" + __FILE__ ") : no such operation %d\n\n" + "active subscripts are not implemented in the safe version" + " of bit pattern reverse mode\n" + , operation); + exit(-1); +#endif /* _SAFE_ */ + break; + +/*--------------------------------------------------------------------------*/ + case m_subscript_ld: /* m_subscript_ld */ + size = get_locint_r(); + arg = get_locint_r(); + arg1 = get_locint_r(); + arg2 = get_locint_r(); +#ifdef _TIGHT_ + d = get_val_v_r(size); + coval = get_val_r(); + + ASSIGN_T( Targ1, T[arg1]) + + if ((int)(coval) != (int)(TARG1)) + MINDEC(ret_c,2); + + res = arg2 + ((int)(TARG1) + 1)*size + arg; + for (ls=size; ls>0; ls--) + { res--; + + get_taylor(res); + + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + ARES_INC = 0; + } +#endif /* _TIGHT_ */ +#ifdef _SAFE_ + fprintf(DIAG_OUT,"ADOL-C fatal error in " GENERATED_FILENAME " (" + __FILE__ ") : no such operation %d\n\n" + "active subscripts are not implemented in the safe version" + " of bit pattern reverse mode\n" + , operation); + exit(-1); +#endif /* _SAFE_ */ + break; + + + +/****************************************************************************/ +/* REMAINING STUFF */ + +/*--------------------------------------------------------------------------*/ + case take_stock_op: /* take_stock_op */ + res = get_locint_r(); + size = get_locint_r(); +#ifdef _TIGHT_ + d = get_val_v_r(size); +#endif /* _TIGHT_ */ + + res += size; + for (ls=size; ls>0; ls--) + { res--; + + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + ARES_INC = 0; + } + break; + +/*--------------------------------------------------------------------------*/ + case death_not: /* death_not */ + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + for (j=arg1;j<=arg2;j++) + { ASSIGN_A(Aarg1, A[j]) + + FOR_0_LE_l_LT_p + AARG1_INC = 0; +#ifdef _TIGHT_ + get_taylor(j); +#endif /* _TIGHT_ */ + } + break; + +/*--------------------------------------------------------------------------*/ + default: /* default */ + /* Die here, we screwed up */ + + fprintf(DIAG_OUT,"ADOL-C fatal error in " GENERATED_FILENAME " (" + __FILE__ + ") : no such operation %d\n", operation); + exit(-1); + break; + } /* endswitch */ + + /* Get the next operation */ + operation=get_op_r(); + } /* endwhile */ + + end_sweep(); + return ret_c; +} + + +/****************************************************************************/ +/* THAT'S ALL */ +#ifdef __cplusplus +} +#endif + +#undef _ADOLC_SRC_ +#undef _INT_REV_C_ + + diff --git a/adol-c/SRC/SPARSE/jacutils.c b/adol-c/SRC/SPARSE/jacutils.c new file mode 100644 index 0000000..0956e36 --- /dev/null +++ b/adol-c/SRC/SPARSE/jacutils.c @@ -0,0 +1,637 @@ +#define _JACUTILS_C_ +#define _ADOLC_SRC_ +/* + ------------------------------------------------------------------------ + File jacutils.c of ADOL-C version 1.8.6 as of Feb/14/2000 + ------------------------------------------------------------------------ + This file contains definitions for the functions prototyped in + jacutils.h. Each function is an ADOL-C straight C utility. + + Last changed : + 20000214 olvo: call to forward required in tight reverse mode only, + in safe reverse mode no basepoint is available! + (By the way, the return values rc are never checked!) + 20000214 olvo: fixed bug according to Andreas Waechter from CMU + 990308 christo: myalloc1_ushort -> myalloc1_uint + 990308 christo: number of blocks : unsigned short -> unsigned int + 990308 christo: bit patterns : unsigned int -> unsigned long int + 990302 christo: new interface of jac_pat(...) + 981203 christo: non-transponded matrices for reverse + 981125 christo: changed options rowblocks, colblocks + 981115 christo: non-contiguous blocks + 981101 christo: changed options, default=safe=0 + + ------------------------------------------------------------------------ +*/ + + +/****************************************************************************/ +/* DEFINES */ + +/* define SHOWBITPATTERN to print the Jacobian bit pattern in reverse mode */ +#undef SHOWBITPATTERN + + +/****************************************************************************/ +/* NECESSARY INCLUDES */ +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" /* Users Parameters */ +#include "jacutils.h" +#include "adalloc.h" + +#include +#include + +#ifdef __cplusplus +extern "C" { +#endif + + +/*****************************************************************************/ +/* JACOBIAN BLOCK PATTERN */ + +/* ------------------------------------------------------------------------- */ +int block_pattern( + short tag, /* tape identification */ + int depen, /* number of dependent variables */ + int indep, /* number of independent variables */ + double *basepoint,/* independant variable values */ + unsigned int *rowblocks, + /* rb[0] = number of blocks of dependent variables + dependent variable j=0..depen-1 belongs to block rb[1+j] */ + unsigned int *columnblocks, + /* cb[0] = number of blocks of independent variables + independent variable i=0..indep-1 belongs to block cb[1+i] */ + unsigned int **crs, + /* compressed block row storage [rb[0]][1 + indep.bl. per row] + crs[depen. bl.][0] = non-zero indep. bl. w.r.t depen. bl. + crs[depen. bl.][1 .. crs[depen. bl.][0]] : + indeces of non-zero blocks of independent variables with + respect to the current block of dependent variables */ + int *options /* control options */ + /* options[0] : way of bit pattern propagation + 0 - automatic detection (default) + 1 - forward mode + 2 - reverse mode + options[1] : test the computational graph control flow + 0 - safe variant (default) + 1 - tight variant + options[2] : output ( 0 in 1 in 2 in 3 ) + 0 - no output (default) + 1 - sparsity (block) patterns output + 2 - mode specification + 3 - seed/Jacobian matrix output as unsigned longs + */ + ) +{ + unsigned int depen_blocks, indep_blocks, *rowbl, *colbl; + + int rc= 3, outp; + char forward_mode, tight_mode, each_depvar_is_block; + int i, ii, j, jj, k, k_old, bits_per_long, i_max, + i_blocks_per_strip, d_blocks_per_strip; + int this_strip_i_bl_idx, next_strip_i_bl_idx, + this_strip_d_bl_idx, next_strip_d_bl_idx; + int stripmined_calls, strip_idx; + int p_stripmine, q_stripmine, p_ind_bl_bp, q_dep_bl_bp, + i_bl_idx, d_bl_idx; + unsigned long int value1, v; + unsigned long int **seed=NULL, *s, **jac_bit_pat=NULL, *jac; + unsigned int *rb, *cb; + unsigned char *indep_blocks_flags=NULL, *i_b_flags; + double *valuepoint=NULL; + + + depen_blocks = rowblocks[0]; /*number of blocks of dependent variables */ + indep_blocks = columnblocks[0]; /*number of blocks of independent variables*/ + rowbl = rowblocks + 1; + colbl = columnblocks + 1; + + if ( options[0] == 0 ) + if ( depen >= indep ) + options[0] = 1; /* forward */ + else + options[0] = 2; /* reverse */ + + if ( options[0] == 1 ) + forward_mode = 1; + else + forward_mode = 0; + + if ( options[1] == 1 ) + tight_mode = 1; + else + tight_mode = 0; + + outp = options[2]; + + if ( ! forward_mode ) + valuepoint = myalloc1(depen); + + /* bit pattern parameters */ + bits_per_long = 8 * sizeof(unsigned long int); /* number of bits in an unsigned long int variable */ + /* olvo 20000214 nl: inserted explicit cast to unsigned long int */ + value1 = (unsigned long int) 1 << (bits_per_long - 1); /* 10000....0 */ + + /* =================================================== forward propagation */ + if ( forward_mode ) + { + + if (( tight_mode ) && ( basepoint == NULL )) + { + fprintf(DIAG_OUT, "ADOL-C error in jac_pat(...) : supply basepoint x for tight mode.\n"); + exit(-1); + } + else + if (outp > 1) + { + printf("jac_pat started in forward, "); + if ( tight_mode ) + printf("tight mode !\n\n"); + else + printf("safe mode !\n\n"); + } + + /* indep partial derivatives for the whole Jacobian */ + + /* number of unsigned longs to store the whole seed / Jacobian matrice */ + p_ind_bl_bp = indep_blocks / bits_per_long + + ( (indep_blocks % bits_per_long) != 0 ); + + /* number of unsigned longs to store the seed / Jacobian strips */ + if ( p_ind_bl_bp <= PQ_STRIPMINE_MAX ) + { + p_stripmine = p_ind_bl_bp; + stripmined_calls = 1; + } + else + { + p_stripmine = PQ_STRIPMINE_MAX; + stripmined_calls = p_ind_bl_bp / PQ_STRIPMINE_MAX + + ( (p_ind_bl_bp % PQ_STRIPMINE_MAX) != 0 ); + } + + /* number of independent blocks per seed / Jacobian strip */ + i_blocks_per_strip = p_stripmine * bits_per_long; + + /* allocate memory --------------------------------------------------- */ + + if ( ! (indep_blocks_flags = (unsigned char*)calloc(i_blocks_per_strip, sizeof(char)) ) ) + { + fprintf(DIAG_OUT, "ADOL-C error, "__FILE__ + ":%i : \njac_pat(...) unable to allocate %i bytes !\n", + __LINE__, i_blocks_per_strip*sizeof(char)); + exit(-1); + } + + seed = myalloc2_ulong(indep, p_stripmine); + jac_bit_pat = myalloc2_ulong(depen, p_stripmine); + + if ( depen == depen_blocks ) + { + each_depvar_is_block = 1; + rb = rowbl; + for (j=0; j int !!! */ + *s++ = 0; /* set old seed matrix to 0 */ + + this_strip_i_bl_idx = strip_idx * i_blocks_per_strip; + next_strip_i_bl_idx = (strip_idx+1) * i_blocks_per_strip; + if ( next_strip_i_bl_idx > indep_blocks ) + next_strip_i_bl_idx = indep_blocks; + v = value1; /* 10000....0 */ + + for (i=0; i block %i -> strip %i\n", i, colbl[i], strip_idx);*/ + /* block colbl[i] belongs to this strip */ + ii = (colbl[i] - this_strip_i_bl_idx) / bits_per_long; + seed[i][ii] = v >> ((colbl[i] - this_strip_i_bl_idx) % bits_per_long); + } + + if (outp > 2) + { + printf("seed matrix (indep x indep_blocks_per_strip) as unsigned long ints : \n"); + for (i=0; i 2) + { + printf("Jacobian (depen x indep_blocks_per_strip) as unsigned long ints: \n"); + for (j=0; j> 1; + } + } + else + for (j=0; j> 1; + } + } + + if ( strip_idx == 0 ) + k_old = 0; + else + k_old = crs[d_bl_idx][0]; + k = 0; + i_b_flags = indep_blocks_flags; + for (i = 0; i < i_blocks_per_strip; i++) + k += *i_b_flags++; + + if ((k > 0 ) || ( strip_idx == 0 )) + { + if ( ! (crs[d_bl_idx] = (unsigned int*)realloc(crs[d_bl_idx], (k_old+k+1)*sizeof(unsigned int))) ) + { + fprintf(DIAG_OUT, "ADOL-C error, "__FILE__ + ":%i : \njac_pat(...) unable to allocate %i bytes !\n", + __LINE__, (k_old+k+1)*sizeof(unsigned int)); + exit(-1); + } + if ( strip_idx == 0 ) + crs[d_bl_idx][0] = 0; + if ( k > 0 ) + { + k = crs[d_bl_idx][0] + 1; + i_b_flags = indep_blocks_flags; + for (i = 0; i < i_blocks_per_strip; i++) + { + if ( *i_b_flags ) + { + crs[d_bl_idx][k++] = this_strip_i_bl_idx + i; + *i_b_flags = 0; + } + i_b_flags++; + } + /* current/total number of non-zero blocks of indep. vars. */ + crs[d_bl_idx][0] = k - 1; + } + } + + } + + } /* strip_idx */ + + } /* forward */ + + + /* =================================================== reverse propagation */ + else + { + if (outp > 1) + { + printf("jac_pat started in reverse, "); + if ( tight_mode ) + printf("tight mode !\n\n"); + else + printf("safe mode !\n\n"); + } + + /* depen weight vectors for the whole Jacobian */ + + /* number of unsigned longs to store the whole seed / Jacobian matrice */ + q_dep_bl_bp = depen_blocks / bits_per_long + + ( (depen_blocks % bits_per_long) != 0 ); + + /* number of unsigned longs to store the seed / Jacobian strips */ + if ( q_dep_bl_bp <= PQ_STRIPMINE_MAX ) + { + q_stripmine = q_dep_bl_bp; + stripmined_calls = 1; + } + else + { + q_stripmine = PQ_STRIPMINE_MAX; + stripmined_calls = q_dep_bl_bp / PQ_STRIPMINE_MAX + + ( (q_dep_bl_bp % PQ_STRIPMINE_MAX) != 0 ); + } + + /* number of dependent blocks per seed / Jacobian strip */ + d_blocks_per_strip = q_stripmine * bits_per_long; + + /* allocate memory --------------------------------------------------- */ + if ( ! (indep_blocks_flags = (unsigned char*)calloc(indep_blocks, sizeof(unsigned char)) ) ) + { + fprintf(DIAG_OUT, "ADOL-C error, "__FILE__ + ":%i : \njac_pat(...) unable to allocate %i bytes !\n", + __LINE__, indep_blocks*sizeof(unsigned char)); + exit(-1); + } + + seed = myalloc2_ulong(q_stripmine, depen); + jac_bit_pat = myalloc2_ulong(q_stripmine, indep); + + + /* olvo 20000214: call to forward required in tight mode only, + in safe mode no basepoint available! */ + if ( tight_mode ) + { if ( basepoint == NULL ) + { fprintf(DIAG_OUT, "ADOL-C error in jac_pat(..) : no basepoint x for tight mode supplied.\n"); + exit(-1); + } + + rc = zos_forward(tag, depen, indep, 1, basepoint, valuepoint); + } + + /* strip-mining : repeated reverse calls ----------------------------- */ + + for (strip_idx = 0; strip_idx < stripmined_calls; strip_idx++) + { + /* build a partition of the seed matrix (depen_blocks x depen) */ + /* (d_blocks_per_strip x depen) as a bit pattern */ + s = seed[0]; + for (jj=0; jj int !!! */ + for (j=0; j depen_blocks ) + next_strip_d_bl_idx = depen_blocks; + v = value1; /* 10000....0 */ + + for (j=0; j block %i -> strip %i\n",j, rowbl[j], strip_idx);*/ + /* block rowbl[j] belongs to this strip */ + jj = (rowbl[j] - this_strip_d_bl_idx) / bits_per_long; + seed[jj][j] = v >> ((rowbl[j] - this_strip_d_bl_idx) % bits_per_long); + } + + if (outp > 2) + { + printf("seed matrix (depen_blocks_per_strip x depen) as unsigned long ints: \n"); + for (jj=0; jj 2) + { + printf("Jacobian (depen_blocks_per_strip x indep) as unsigned long ints: \n"); + for (jj=0; jj 2) + printf("Jacobian (depen_blocks_per_strip x indep) as a bit pattern: \n"); +#endif + + jj = -1; + v = 0; + for (d_bl_idx = this_strip_d_bl_idx; + d_bl_idx < next_strip_d_bl_idx; d_bl_idx++) + { + if ( !v ) + { + v = value1; /* 10000....0 */ + jj++; + } + jac = jac_bit_pat[jj]; + for (i=0; i 2) + printf("X "); +#endif + } +#ifdef SHOWBITPATTERN + else + if (outp > 2) + printf("%c ",183); +#endif + } + + v = v >> 1; + +#ifdef SHOWBITPATTERN + if (outp > 2) + printf("\n"); +#endif + k=0; + i_b_flags = indep_blocks_flags; + for (i=0; i 0) + { + printf("\nJacobian Block Pattern :\n"); + for (j=0; j myalloc1_uint + 990308 christo: block_pattern : number of blocks : + unsigned short -> unsigned int + 990308 christo: bit patterns : unsigned int -> unsigned long int + 981203 olvo: untransposing reverse + 981130 olvo: includes changed + 981126 olvo: last check (p's & q's) + 981125 christo: changed block_pattern() parameter list + 981118 christo: changed block_pattern() parameter list + 981101 christo: changed block_pattern() parameter values + + ----------------------------------------------------------------- +*/ + +/****************************************************************************/ +/* MAKROS */ + +/* Max. number of unsigned ints to store the seed / jacobian matrix strips. + Reduce this value to x if your system happens to run out of memory. + x < 10 makes no sense. x = 50 or 100 is better + x stays for ( x * sizeof(unsigned long int) * 8 ) + (block) variables at once */ +#define PQ_STRIPMINE_MAX 30 + + +/****************************************************************************/ +/****************************************************************************/ +/****************************************************************************/ +/* PUBLIC EXPORTS ONLY */ + +#ifdef __cplusplus +/****************************************************************************/ +/****************************************************************************/ +/* No C++ THINGS */ + + +/****************************************************************************/ +/****************************************************************************/ +/* Now the C THINGS */ +extern "C" { +#endif + +/****************************************************************************/ +/* BIT PATTERN UTILITIES */ + +/*--------------------------------------------------------------------------*/ +/* int_forward_tight(tag, m, n, p, x[n], X[n][p], y[m], Y[m][p]) */ + +int int_forward_tight(short, int, int, int, double*, unsigned long int**, + double*, unsigned long int**); + + +/*--------------------------------------------------------------------------*/ +/* int_forward_safe(tag, m, n, p, X[n][p], Y[m][p]) */ + +int int_forward_safe(short, int, int, int, unsigned long int**, + unsigned long int**); + + +/*--------------------------------------------------------------------------*/ +/* int_reverse_tight(tag, m, n, q, U[q][m], Z[q][n]) */ + +int int_reverse_tight(short, int, int, int, unsigned long int**, + unsigned long int**); + + +/*--------------------------------------------------------------------------*/ +/* int_reverse_safe(tag, m, n, q, U[q][m], Z[q][n]) */ + +int int_reverse_safe(short, int, int, int, unsigned long int**, + unsigned long int**); + + +/****************************************************************************/ +/* JACOBIAN BLOCK PATTERN */ + +int block_pattern(short, int, int, double*, unsigned int*, unsigned int*, + unsigned int**, int*); + + +/****************************************************************************/ +/* MEMORY MANAGEMENT UTILITIES */ + +unsigned int * myalloc1_uint(int); + +unsigned long int * myalloc1_ulong(int); +unsigned long int ** myalloc2_ulong(int, int); + + +/****************************************************************************/ +/* THAT'S ALL */ +#ifdef __cplusplus +} +#endif + +#endif diff --git a/adol-c/SRC/SPARSE/sparse.c b/adol-c/SRC/SPARSE/sparse.c new file mode 100644 index 0000000..98fc6e0 --- /dev/null +++ b/adol-c/SRC/SPARSE/sparse.c @@ -0,0 +1,146 @@ +#define _SPARSEC_C_ +#define _ADOLC_SRC_ +/* + -------------------------------------------------------------- + File sparsec.c of ADOL-C version 1.8.2 as of Mar/09/99 + -------------------------------------------------------------- + All "Easy To Use" C interfaces of SPARSE package + + Last changes: + 990308 christo: myalloc1_ushort -> myalloc1_uint + 990302 christo: new interface of jac_pat(...) + 981130 olvo: newly created from driversc.c + + -------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/* INCLUDES */ +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" /* Users Parameters */ +#include "sparse.h" +#include "jacutils.h" + +#include +#include + +#ifdef __cplusplus +#include +extern "C" { +#endif + + +/*---------------------------------------------------------------------------*/ +/* jacobian pattern */ +/* */ + +int jac_pat( + short tag, /* tape identification */ + int depen, /* number of dependent variables */ + int indep, /* number of independent variables */ + double *basepoint, /* independant variable values */ + unsigned int *rb, + /* rb[0] = number of blocks of dependent variables + dependent variable j=0..depen-1 belongs to row block rb[1+j], + if rb == NULL each dependent variable will be considered + as a block of dependent variables (rb[0]=depen) */ + unsigned int *cb, + /* cb[0] = number of blocks of independent variables + independent variable i=0..indep-1 belongs to column block cb[1+i] + if cb == NULL each independent variable will be considered + as a block of independent variables (cb[0]=indep) */ + unsigned int **crs, + /* returned compressed row block-index storage + crs[ rb[0] ][ non-zero blocks of independent variables per row ] + crs[depen. block][0] = non-zero indep. bl. w.r.t current depen. bl. + crs[depen. block][1 .. crs[depen. bl.][0]] : + indeces of non-zero blocks of independent variables with + respect to the current block of dependent variables */ + int *options + /* control options + options[0] : way of bit pattern propagation + 0 - automatic detection (default) + 1 - forward mode + 2 - reverse mode + options[1] : test the computational graph control flow + 0 - safe mode (default) + 1 - tight mode */ + + ) +{ + int rc= -1, i, j; + unsigned int depen_blocks, indep_blocks, *rowbl, *colbl; + int ctrl_options[3]; + + if (rb == NULL) + { + rb = myalloc1_uint(1+depen); + rowbl = rb; + *rowbl++ = depen; + for (j=0; j= depen_blocks ) + { + fprintf(DIAG_OUT,"ADOL-C user error in jac_pat(...) : " + "bad dependent block index rb[%i]=%i >= rb[0]=%i !\n", + j+1, *(rowbl-1), depen_blocks); + exit(-1); + } + colbl = cb; + indep_blocks = *colbl++; + for (i=0; i= indep_blocks ) + { + fprintf(DIAG_OUT,"ADOL-C user error in jac_pat(...) : " + "bad independent block index cb[%i]=%i >= cb[0]=%i !\n", + i+1, *(colbl-1), indep_blocks); + exit(-1); + } + + if (crs == NULL) + { + fprintf(DIAG_OUT,"ADOL-C user error in jac_pat(...) : " + "parameter crs may not be NULL !\n"); + exit(-1); + } + else + for (i=0; i 2 )) + options[0] = 0; /* default */ + if (( options[1] < 0 ) || (options[1] > 1 )) + options[1] = 0; /* default */ + ctrl_options[0] = options[0]; + ctrl_options[1] = options[1]; + ctrl_options[2] = 0; /* no output intern */ + + rc = block_pattern( tag, depen, indep, basepoint, + rb, cb, crs, ctrl_options); + + return(rc); +} + +/****************************************************************************/ +/* THAT'S ALL */ + +#ifdef __cplusplus +} +#endif + +#undef _ADOLC_SRC_ +#undef _SPARSEC_C_ diff --git a/adol-c/SRC/SPARSE/sparse.h b/adol-c/SRC/SPARSE/sparse.h new file mode 100644 index 0000000..d1819ef --- /dev/null +++ b/adol-c/SRC/SPARSE/sparse.h @@ -0,0 +1,109 @@ +#ifndef _SPARSE_H_ +#define _SPARSE_H_ +/* + -------------------------------------------------------------- + File sparse.h of ADOL-C version 1.8.2 as of Mar/09/99 + -------------------------------------------------------------- + All "Easy To Use" interfaces of SPARSE package + + Last changes: + 990308 christo: bit patterns : unsigned int -> unsigned long int + 990308 christo: mode : short -> char + 990302 christo: new interface of jac_pat(...) + 981203 olvo: untransposing reverse + 981130 olvo: newly created from adutils.h & adutilsc.h + + -------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/****************************************************************************/ +/****************************************************************************/ +/* PUBLIC INTERFACES */ + +#ifdef __cplusplus +/****************************************************************************/ +/****************************************************************************/ +/* Now the C++ THINGS */ + +/****************************************************************************/ +/* FORWARD MODE, overloaded calls */ + +/* nBV = number of Boolean Vectors to be packed + (see Chapter Dependence Analysis, ADOL-C Documentation) + bits_per_long = 8*sizeof(unsigned long int) + p = nBV / bits_per_long + ( (nBV % bits_per_long) != 0 ) + + For the full Jacobian matrix set + p = indep / bits_per_long + ((indep % bits_per_long) != 0) + and pass a bit pattern version of the identity matrix as an argument */ + +/*--------------------------------------------------------------------------*/ +/* Bit pattern propagation call, d = 1, tight version */ +/* */ +/* forward(tag, m, n, p, x[n], X[n][p], y[m], Y[m][p], mode) : intfov */ + +int forward(short, int, int, int, double*, unsigned long int**, + double*, unsigned long int**, char =0); + +/*--------------------------------------------------------------------------*/ +/* Bit pattern propagation call, d = 1, safe version (no x[] and y[]) */ +/* */ +/* forward(tag, m, n, p, X[n][p], Y[m][p], mode) : intfov */ + +int forward(short, int, int, int, unsigned long int**, unsigned long int**, char =0); + + +/****************************************************************************/ +/* REVERSE MODE, overloaded calls */ + +/* nBV = number of Boolean Vectors to be packed + (see Chapter Dependence Analysis, ADOL-C Documentation) + bits_per_long = 8*sizeof(unsigned long int) + q = nBV / bits_per_long + ( (nBV % bits_per_long) != 0 ) + + For the full Jacobian matrix set + q = depen / bits_per_long + ((depen % bits_per_long) != 0) + and pass a bit pattern version of the identity matrix as an argument */ + +/*--------------------------------------------------------------------------*/ +/* */ +/* Bit pattern propagation call, d = 0, tight & safe version */ +/* */ +/* reverse(tag, m, n, q, U[q][m], Z[q][n], mode) : intfov */ + +int reverse(short, int, int, int, unsigned long int**, unsigned long int**, char =0); + + +/****************************************************************************/ +/****************************************************************************/ +/* Now the C THINGS */ +extern "C" { +#endif + + +/*--------------------------------------------------------------------------*/ +/* jacobian pattern */ +/* jac_pat(tag, m, n, argument, + rb[1+m], cb[1+n], + crs[rb[0]][ crs[][0] = non-zero independent blocks per row ], + options[2]) + + if (rb == NULL) each dependent variable will be considered + as a block of dependent variables. + if (cb == NULL) each independent variable will be considered + as a block of independent variables. */ + + +int jac_pat(short,int,int,double*,unsigned int*,unsigned int*, + unsigned int**,int*); + + +/****************************************************************************/ +/* THAT'S ALL */ +#ifdef __cplusplus +} +#endif + +#endif diff --git a/adol-c/SRC/SPARSE/sparseC.C b/adol-c/SRC/SPARSE/sparseC.C new file mode 100644 index 0000000..62152a3 --- /dev/null +++ b/adol-c/SRC/SPARSE/sparseC.C @@ -0,0 +1,121 @@ +#define _SPARSEC_CPP_ +#define _ADOLC_SRC_ +/* + -------------------------------------------------------------- + File sparseC.C of ADOL-C version 1.8.2 as of Mar/09/99 + -------------------------------------------------------------- + All "Easy To Use" C++ interfaces of SPARSE package + + Last changes: + 990308 christo bit patterns : unsigned int -> unsigned long int + 990308 christo mode : short -> char + 981203 olvo: untransposing reverse + 981201 olvo: newly created from interfaces.C + + -------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/* INCLUDES */ +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" /* Users Parameters */ +#include "sparse.h" +#include "jacutils.h" + +#include +#include +#include + + +/****************************************************************************/ +/* Bit pattern propagation; general call */ +/* */ +int forward( short tag, + int m, + int n, + int p, + double *x, + unsigned long int **X, + double *y, + unsigned long int **Y, + char mode) +/* forward(tag, m, n, p, x[n], X[n][p], y[m], Y[m][p], mode) */ +{ + int rc = -1; + if (mode == 1) // tight version + if (x != NULL) + rc = int_forward_tight(tag,m,n,p,x,X,y,Y); + else + { fprintf(DIAG_OUT,"ADOL-C error: no basepoint for bit" + " pattern forward tight.\n"); + exit(-1); + } + else + if (mode == 0) // safe version + rc = int_forward_safe(tag,m,n,p,X,Y); + else + { fprintf(DIAG_OUT,"ADOL-C error: bad mode parameter to bit" + " pattern forward.\n"); + exit(-1); + } + return (rc); +} + + +/****************************************************************************/ +/* Bit pattern propagation; no basepoint */ +/* */ +int forward( short tag, + int m, + int n, + int p, + unsigned long int **X, + unsigned long int **Y, + char mode) +/* forward(tag, m, n, p, X[n][p], Y[m][p], mode) */ +{ + if (mode != 0) // not safe + { fprintf(DIAG_OUT,"ADOL-C error: bad mode parameter to bit" + " pattern forward.\n"); + exit(-1); + } + return int_forward_safe(tag,m,n,p,X,Y); +} + + + +/****************************************************************************/ +/* */ +/* Bit pattern propagation, general call */ +/* */ +int reverse( short tag, + int m, + int n, + int q, + unsigned long int **U, + unsigned long int **Z, + char mode) +/* reverse(tag, m, n, q, U[q][m], Z[q][n]) */ +{ int rc=-1; + + /* ! use better the tight version, the safe version supports no subscripts*/ + + if (mode == 0) // safe version + rc = int_reverse_safe(tag,m,n,q,U,Z); + else + if (mode == 1) + rc = int_reverse_tight(tag,m,n,q,U,Z); + else + { fprintf(DIAG_OUT,"ADOL-C error: bad mode parameter" + " to bit pattern reverse.\n"); + exit(-1); + } + return rc; +} + + +/****************************************************************************/ +/* THAT'S ALL */ +#undef _ADOLC_SRC_ +#undef _SPARSEC_CPP_ diff --git a/adol-c/SRC/TAPEDOC/tapedoc.c b/adol-c/SRC/TAPEDOC/tapedoc.c new file mode 100644 index 0000000..134d802 --- /dev/null +++ b/adol-c/SRC/TAPEDOC/tapedoc.c @@ -0,0 +1,1581 @@ +#define _TAPEDOC_C_ +#define _ADOLC_SRC_ +/* + ---------------------------------------------------------------- + File tapedoc.c of ADOL-C version 1.8.5 as of Nov/22/99 + ---------------------------------------------------------------- + Routine tape_doc(..) writes the taped operations in LaTeX-code + to the file tape_doc.tex + + Last changes: + 991122 olvo new op_codes eq_plus_prod eq_min_prod + for y += x1 * x2 + and y -= x1 * x2 + 981130 olvo last check (includes ...) + 980930 olvo allow reflexive vecops + 980924 olvo deleted all int_* opcodes + 980923 olvo allow reflexive ops + 980820 olvo new comparison strategy + 980714 olvo: removed operation code: mult_av_a + 980709 olvo: new operation code: neg_sign_a + pos_sign_a + 980706 olvo: new operation code: assign_d_one + assign_d_zero + int_adb_d_one + int_adb_d_zero + incr_a + decr_a + 980623 olvo: new operation code: take_stock_op + ---------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/* NECESSARY INCLUDES */ +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" +#include "oplate.h" +#include "taputil.h" +#include "tayutil.h" +#include "adalloc.h" + +#include +#include + +#ifdef __cplusplus +extern "C" { +#endif + + +/****************************************************************************/ +/* MACROS */ +#define computenumbers true + + +/****************************************************************************/ +/* STATIC VARIABLES */ + +/*--------------------------------------------------------------------------*/ +static short tag; + +static int for_location_cnt; + +static int length; +static int page; +static int file_cnt; +static int read_cnt; +static int pagelength; +static FILE *fp; + +/*--------------------------------------------------------------------------*/ +/* operation names */ +static char* a[] = { "ignore me","death not","assign ind", + "assign dep","assign a","assign d", + "eq plus d","eq plus a","eq min d", + "eq min a","eq mult d","eq mult a", + "plus a a","plus d a","min a a", + "min d a","mult a a","mult d a", + "div a a","div d a","exp op", + "cos op","sin op","atan op","log op", + "pow op","asin op","acos op","sqrt op", + "eq div a","eq div d","tan op","gen quad", + "not used","not used","end of tape", + "start of tape","end of op","end of int", + "end of val","plus av av","plus dv av", + "sub av av","sub dv av","sub av dv", + "dot av av","dot dv av","mult a av", + "mult d av","mult a dv","not used", + "not used","assign av","assign dv", + "assign indvec","assign depvec","eq min dv", + "eq min av","eq plus dv","eq plus av", + "div av a","eq mult av d","eq mult av a", + "dot av dv","nicht belegt","nicht belegt", + "not used","not used","not used", + "not used","cond assign $\\longrightarrow$", + "cond assign s $\\longrightarrow$", + "m subscript $\\longrightarrow$", + "m subscript l $\\longrightarrow$", + "m subscript ld $\\longrightarrow$", + "subscript $\\longrightarrow$", + "subscript l $\\longrightarrow$", + "subscript ld $\\longrightarrow$", + "not used","not used", + "cross av av","mult cv3 av4","not used", + "not used","not used","not used","not used", + "not used","not used","not used","take stock op", + "assign d one","assign d zero","not used", + "not used","incr a","decr a","neg sign a", + "pos sign a","not used","min op","abs val", + "eq zero","neq zero","le zero","gt zero", + "ge zero","lt zero","not used","not used", + "eq plus prod","eq min prod","not used","not used", + "erf op","ceil op","floor op" + }; + +/****************************************************************************/ +/* LOCAL WRITE ROUTINES */ + +/*--------------------------------------------------------------------------*/ +void filewrite_start( int opcode ) +{ if ((fp = fopen("tape.tex","w")) == NULL) + { fprintf(DIAG_OUT,"cannot open file !\n"); + exit(1); + } + fprintf(fp,"\\documentstyle{article} \n"); + fprintf(fp,"\\headheight0cm\n"); + fprintf(fp,"\\headsep-1cm\n"); + fprintf(fp,"\\textheight25cm\n"); + fprintf(fp,"\\oddsidemargin-1cm\n"); + fprintf(fp,"\\topmargin0cm\n"); + fprintf(fp,"\\textwidth18cm\n"); + fprintf(fp,"\\begin{document}\n"); + fprintf(fp,"\\tiny\n"); +#ifdef computenumbers + fprintf(fp,"\\begin{tabular}{|r|l|r|r|r|r||r|r||r|r|r|r|} \\hline \n"); + fprintf(fp," code & op & loc & loc & loc & loc & double & double & value & value & value & value \\\\ \\hline \n"); + fprintf(fp," %i & start of tape & & & & & & & & & & \\\\ \\hline \n",opcode); +#else + fprintf(fp,"\\begin{tabular}{|r|l|r|r|r|r||r|r|} \\hline \n"); + fprintf(fp," code & op & loc & loc & loc & loc & double & double \\\\ \\hline \n"); + fprintf(fp," %i & start of tape & & & & & & & \\\\ \\hline \n",opcode); +#endif + pagelength = 0; +} + +/*--------------------------------------------------------------------------*/ +void filewrite( unsigned short opcode, int nloc, int *loc, + double *val,int ncst, double* cst) +{ int i, j, k; + if (pagelength == 100) + { fprintf(fp,"\\end{tabular}\\\\\n"); + fprintf(fp,"\\newpage\n"); +#ifdef computenumbers + fprintf(fp,"\\begin{tabular}{|r|l|r|r|r|r||r|r||r|r|r|r|} \\hline \n"); + fprintf(fp," code & op & loc & loc & loc & loc & double & double & value & value & value & value \\\\ \\hline \n"); +#else + fprintf(fp,"\\begin{tabular}{|r|l|r|r|r|r||r|r|} \\hline \n"); + fprintf(fp," code & op & loc & loc & loc & loc & double & double \\\\ \\hline \n"); +#endif + pagelength=-1; + } + fprintf(fp,"%i & ",opcode); + + i=0; + while (a[opcode][i]) + { fprintf(fp,"%c",a[opcode][i]); + i++; + } + + fprintf(fp," &"); + for(i=0; i<(4-nloc); i++) + fprintf(fp," &"); + for(i=0; i>=) */ + res = get_locint_f(); + loc_a[0]=res; +#ifdef computenumbers + val_a[0]=T0[res]; + valuepoint[indexd++]=T0[res]; +#endif + filewrite(operation,1,loc_a,val_a,0,cst_d); + break; + + +/****************************************************************************/ +/* OPERATION + ASSIGNMENT */ + +/*--------------------------------------------------------------------------*/ + case eq_plus_d: /* Add a floating point to an eq_plus_d */ + /* adouble. (+=) */ + res = get_locint_f(); + coval = get_val_f(); + loc_a[0] = res; + cst_d[0] = coval; +#ifdef computenumbers + T0[res] += coval; + val_a[0] = T0[res]; +#endif + filewrite(operation,1,loc_a,val_a,1,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case eq_plus_a: /* Add an adouble to another eq_plus_a */ + /* adouble. (+=) */ + arg = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg; + loc_a[1]=res; +#ifdef computenumbers + val_a[0]=T0[arg]; + T0[res]+= T0[arg]; + val_a[1]=T0[res]; +#endif + filewrite(operation,2,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case eq_plus_prod: /* Add an product to an eq_plus_prod */ + /* adouble. (+= x1*x2) */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg1; + loc_a[1]=arg2; + loc_a[2]=res; +#ifdef computenumbers + val_a[0]=T0[arg1]; + val_a[1]=T0[arg2]; + T0[res] += T0[arg1]*T0[arg2]; + val_a[2]=T0[res]; +#endif + filewrite(operation,3,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case eq_min_d: /* Subtract a floating point from an eq_min_d */ + /* adouble. (-=) */ + res = get_locint_f(); + coval = get_val_f(); + loc_a[0] = res; + cst_d[0] = coval; +#ifdef computenumbers + T0[res] -= coval; + val_a[0] = T0[res]; +#endif + filewrite(operation,1,loc_a,val_a,1,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case eq_min_a: /* Subtract an adouble from another eq_min_a */ + /* adouble. (-=) */ + arg = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg; + loc_a[1]=res; +#ifdef computenumbers + val_a[0]=T0[arg]; + T0[res]-= T0[arg]; + val_a[1]=T0[res]; +#endif + filewrite(operation,2,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case eq_min_prod: /* Subtract an product from an eq_min_prod */ + /* adouble. (+= x1*x2) */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg1; + loc_a[1]=arg2; + loc_a[2]=res; +#ifdef computenumbers + val_a[0]=T0[arg1]; + val_a[1]=T0[arg2]; + T0[res] -= T0[arg1]*T0[arg2]; + val_a[2]=T0[res]; +#endif + filewrite(operation,3,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case eq_mult_d: /* Multiply an adouble by a eq_mult_d */ + /* flaoting point. (*=) */ + res = get_locint_f(); + coval = get_val_f(); + loc_a[0] = res; + cst_d[0] = coval; +#ifdef computenumbers + T0[res] *= coval; + val_a[0] = T0[res]; +#endif + filewrite(operation,1,loc_a,val_a,1,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case eq_mult_a: /* Multiply one adouble by another eq_mult_a */ + /* (*=) */ + arg = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg; + loc_a[1]=res; +#ifdef computenumbers + val_a[0]=T0[arg]; + T0[res]*= T0[arg]; + val_a[1]=T0[res]; +#endif + filewrite(operation,2,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case incr_a: /* Increment an adouble incr_a */ + res = get_locint_f(); + loc_a[0] = res; +#ifdef computenumbers + T0[res]++; + val_a[0] = T0[res]; +#endif + filewrite(operation,1,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case decr_a: /* Increment an adouble decr_a */ + res = get_locint_f(); + loc_a[0] = res; +#ifdef computenumbers + T0[res]--; + val_a[0] = T0[res]; +#endif + filewrite(operation,1,loc_a,val_a,0,cst_d); + break; + + +/****************************************************************************/ +/* BINARY OPERATIONS */ + +/*--------------------------------------------------------------------------*/ + case plus_a_a: /* : Add two adoubles. (+) plus a_a */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg1; + loc_a[1]=arg2; + loc_a[2]=res; +#ifdef computenumbers + val_a[0]=T0[arg1]; + val_a[1]=T0[arg2]; + T0[res]=T0[arg1]+T0[arg2]; + val_a[2]=T0[res]; +#endif + filewrite(operation,3,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case plus_d_a: /* Add an adouble and a double plus_d_a */ + /* (+) */ + arg = get_locint_f(); + res = get_locint_f(); + coval = get_val_f(); + loc_a[0] = arg; + loc_a[1] = res; + cst_d[0] = coval; +#ifdef computenumbers + val_a[0]=T0[arg]; + T0[res]= T0[arg] + coval; + val_a[1]=T0[res]; +#endif + filewrite(operation,2,loc_a,val_a,1,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case min_a_a: /* Subtraction of two adoubles min_a_a */ + /* (-) */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg1; + loc_a[1]=arg2; + loc_a[2]=res; +#ifdef computenumbers + val_a[0]=T0[arg1]; + val_a[1]=T0[arg2]; + T0[res]=T0[arg1]-T0[arg2]; + val_a[2]=T0[res]; +#endif + filewrite(operation,3,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case min_d_a: /* Subtract an adouble from a min_d_a */ + /* double (-) */ + arg = get_locint_f(); + res = get_locint_f(); + coval = get_val_f(); + loc_a[0] = arg; + loc_a[1] = res; + cst_d[0] = coval; +#ifdef computenumbers + val_a[0] = T0[arg]; + T0[res] = coval - T0[arg]; + val_a[1] = T0[res]; +#endif + filewrite(operation,2,loc_a,val_a,1,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case mult_a_a: /* Multiply two adoubles (*) mult_a_a */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg1; + loc_a[1]=arg2; + loc_a[2]=res; +#ifdef computenumbers + val_a[0]=T0[arg1]; + val_a[1]=T0[arg2]; + T0[res]=T0[arg1]*T0[arg2]; + val_a[2]=T0[res]; +#endif + filewrite(operation,3,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case mult_d_a: /* Multiply an adouble by a double mult_d_a */ + /* (*) */ + arg = get_locint_f(); + res = get_locint_f(); + coval = get_val_f(); + loc_a[0] = arg; + loc_a[1] = res; + cst_d[0] = coval; +#ifdef computenumbers + val_a[0] = T0[arg]; + T0[res] = coval * T0[arg]; + val_a[1] = T0[res]; +#endif + filewrite(operation,2,loc_a,val_a,1,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case div_a_a: /* Divide an adouble by an adouble div_a_a */ + /* (/) */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg1; + loc_a[1]=arg2; + loc_a[2]=res; +#ifdef computenumbers + val_a[0]=T0[arg1]; + val_a[1]=T0[arg2]; + T0[res]=T0[arg1]/T0[arg2]; + val_a[2]=T0[res]; +#endif + filewrite(operation,3,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case div_d_a: /* Division double - adouble (/) div_d_a */ + arg = get_locint_f(); + res = get_locint_f(); + coval = get_val_f(); + loc_a[0] = arg; + loc_a[1] = res; + cst_d[0] = coval; +#ifdef computenumbers + val_a[0] = T0[arg]; + T0[res] = coval / T0[arg]; + val_a[1] = T0[res]; +#endif + filewrite(operation,2,loc_a,val_a,1,cst_d); + break; + + +/****************************************************************************/ +/* SIGN OPERATIONS */ + +/*--------------------------------------------------------------------------*/ + case pos_sign_a: /* pos_sign_a */ + arg = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg; + loc_a[1]=res; +#ifdef computenumbers + val_a[0]=T0[arg]; + T0[res]= T0[arg]; + val_a[1]=T0[res]; +#endif + filewrite(operation,2,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case neg_sign_a: /* neg_sign_a */ + arg = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg; + loc_a[1]=res; +#ifdef computenumbers + val_a[0]=T0[arg]; + T0[res]= -T0[arg]; + val_a[1]=T0[res]; +#endif + filewrite(operation,2,loc_a,val_a,0,cst_d); + break; + + +/****************************************************************************/ +/* UNARY OPERATIONS */ + +/*--------------------------------------------------------------------------*/ + case exp_op: /* exponent operation exp_op */ + arg = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg; + loc_a[1]=res; +#ifdef computenumbers + val_a[0]=T0[arg]; + T0[res]= exp(T0[arg]); + val_a[1]=T0[res]; +#endif + filewrite(operation,2,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case sin_op: /* sine operation sin_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg1; + loc_a[1]=arg2; + loc_a[2]=res; +#ifdef computenumbers + /* olvo 980923 changed order to allow x=sin(x) */ + val_a[0]=T0[arg1]; + T0[arg2]= cos(T0[arg1]); + T0[res] = sin(T0[arg1]); + val_a[1]=T0[arg2]; + val_a[2]=T0[res]; +#endif + filewrite(operation,3,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case cos_op: /* cosine operation cos_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg1; + loc_a[1]=arg2; + loc_a[2]=res; +#ifdef computenumbers + /* olvo 980923 changed order to allow x=cos(x) */ + val_a[0]=T0[arg1]; + T0[arg2]= sin(T0[arg1]); + T0[res] = cos(T0[arg1]); + val_a[1]=T0[arg2]; + val_a[2]=T0[res]; +#endif + filewrite(operation,3,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case atan_op: /* atan_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg1; + loc_a[1]=arg2; + loc_a[2]=res; +#ifdef computenumbers + val_a[0]=T0[arg1]; + T0[res] = atan(T0[arg1]); + val_a[1]=T0[arg2]; + val_a[2]=T0[res]; +#endif + filewrite(operation,3,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case asin_op: /* asin_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg1; + loc_a[1]=arg2; + loc_a[2]=res; +#ifdef computenumbers + val_a[0]=T0[arg1]; + T0[res] = asin(T0[arg1]); + val_a[1]=T0[arg2]; + val_a[2]=T0[res]; +#endif + filewrite(operation,3,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case acos_op: /* acos_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg1; + loc_a[1]=arg2; + loc_a[2]=res; +#ifdef computenumbers + val_a[0]=T0[arg1]; + T0[res] = acos(T0[arg1]); + val_a[1]=T0[arg2]; + val_a[2]=T0[res]; +#endif + filewrite(operation,3,loc_a,val_a,0,cst_d); + break; + +#ifdef ATRIG_ERF + +/*--------------------------------------------------------------------------*/ + case asinh_op: /* asinh_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg1; + loc_a[1]=arg2; + loc_a[2]=res; +#ifdef computenumbers + val_a[0]=T0[arg1]; + T0[res] = asinh(T0[arg1]); + val_a[1]=T0[arg2]; + val_a[2]=T0[res]; +#endif + filewrite(operation,3,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case acosh_op: /* acosh_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg1; + loc_a[1]=arg2; + loc_a[2]=res; +#ifdef computenumbers + val_a[0]=T0[arg1]; + T0[res] = acosh(T0[arg1]); + val_a[1]=T0[arg2]; + val_a[2]=T0[res]; +#endif + filewrite(operation,3,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case atanh_op: /* atanh_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg1; + loc_a[1]=arg2; + loc_a[2]=res; +#ifdef computenumbers + val_a[0]=T0[arg1]; + T0[res] = atanh(T0[arg1]); + val_a[1]=T0[arg2]; + val_a[2]=T0[res]; +#endif + filewrite(operation,3,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case erf_op: /* erf_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg1; + loc_a[1]=arg2; + loc_a[2]=res; +#ifdef computenumbers + val_a[0]=T0[arg1]; + T0[res] = erf(T0[arg1]); + val_a[1]=T0[arg2]; + val_a[2]=T0[res]; +#endif + filewrite(operation,3,loc_a,val_a,0,cst_d); + break; + +#endif +/*--------------------------------------------------------------------------*/ + case log_op: /* log_op */ + arg = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg; + loc_a[1]=res; +#ifdef computenumbers + val_a[0]=T0[arg]; + T0[res]= log(T0[arg]); + val_a[1]=T0[res]; +#endif + filewrite(operation,2,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case pow_op: /* pow_op */ + arg = get_locint_f(); + res = get_locint_f(); + coval = get_val_f(); + cst_d[0]=coval; + loc_a[0]=arg; + loc_a[1]=res; +#ifdef computenumbers + val_a[0]=T0[arg]; + T0[res] = pow(T0[arg],coval); + val_a[1]=T0[res]; +#endif + filewrite(operation,2,loc_a,val_a,1,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case sqrt_op: /* sqrt_op */ + arg = get_locint_f(); + res = get_locint_f(); + loc_a[0]=arg; + loc_a[1]=res; +#ifdef computenumbers + val_a[0]=T0[arg]; + T0[res]= sqrt(T0[arg]); + val_a[1]=T0[res]; +#endif + filewrite(operation,2,loc_a,val_a,0,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case gen_quad: /* gen_quad */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + cst_d[0] = get_val_f(); + cst_d[1] = get_val_f(); + loc_a[0]=arg1; + loc_a[1]=arg2; + loc_a[2]=res; +#ifdef computenumbers + val_a[0]=T0[arg1]; + T0[res] = cst_d[1]; + val_a[1]=T0[arg2]; + val_a[2]=T0[res]; +#endif + filewrite(operation,3,loc_a,val_a,2,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case min_op: /* min_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + coval = get_val_f(); + loc_a[0] = arg1; + loc_a[1] = arg2; + loc_a[2] = res; + cst_d[0] = coval; +#ifdef computenumbers + val_a[0] = T0[arg1]; + val_a[1] = T0[arg2]; + if (T0[arg1] > T0[arg2]) + T0[res] = T0[arg2]; + else + T0[res] = T0[arg1]; + val_a[2] = T0[res]; +#endif + filewrite(operation,3,loc_a,val_a,1,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case abs_val: /* abs_val */ + arg = get_locint_f(); + res = get_locint_f(); + coval = get_val_f(); + loc_a[0] = arg; + loc_a[1] = res; + cst_d[0] = coval; +#ifdef computenumbers + val_a[0] = T0[arg]; + T0[res] = fabs(T0[arg]); + val_a[1] = T0[res]; +#endif + filewrite(operation,2,loc_a,val_a,1,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case ceil_op: /* ceil_op */ + arg = get_locint_f(); + res = get_locint_f(); + coval = get_val_f(); + loc_a[0] = arg; + loc_a[1] = res; + cst_d[0] = coval; +#ifdef computenumbers + val_a[0] = T0[arg]; + T0[res] = ceil(T0[arg]); + val_a[1] = T0[res]; +#endif + filewrite(operation,2,loc_a,val_a,1,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case floor_op: /* Compute ceil of adouble floor_op */ + arg = get_locint_f(); + res = get_locint_f(); + coval = get_val_f(); + loc_a[0] = arg; + loc_a[1] = res; + cst_d[0] = coval; +#ifdef computenumbers + val_a[0] = T0[arg]; + T0[res] = floor(T0[arg]); + val_a[1] = T0[res]; +#endif + filewrite(operation,2,loc_a,val_a,1,cst_d); + break; + + +/****************************************************************************/ +/* CONDITIONALS */ + +/*--------------------------------------------------------------------------*/ + case cond_assign: /* cond_assign */ + arg = get_locint_f(); + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + coval = get_val_f(); + loc_a[0]=arg; + loc_a[1]=arg1; + loc_a[2]=arg2 ; + loc_a[3]=res; + cst_d[0]=coval; +#ifdef computenumbers + val_a[0]=T0[arg]; + val_a[1]=T0[arg1]; + val_a[2]=T0[arg2]; + if (T0[arg]>0) + T0[res]=T0[arg1]; + else + T0[res]=T0[arg2]; + val_a[3]=T0[res]; +#endif + filewrite(operation,4,loc_a,val_a,1,cst_d); + break; + +/*--------------------------------------------------------------------------*/ + case cond_assign_s: /* cond_assign_s */ + arg = get_locint_f(); + arg1 = get_locint_f(); + res = get_locint_f(); + coval = get_val_f(); + loc_a[0]=arg; + loc_a[1]=arg1; + loc_a[2]=res; + cst_d[0]=coval; +#ifdef computenumbers + val_a[0]=T0[arg]; + val_a[1]=T0[arg1]; + if (T0[arg]>0) + T0[res]=T0[arg1]; + val_a[2]=T0[res]; +#endif + filewrite(operation,3,loc_a,val_a,1,cst_d); + break; + + +/****************************************************************************/ +/* VECTOR ASSIGNMENTS */ + +/*--------------------------------------------------------------------------*/ + case assign_av: /* assign_av */ + arg = get_locint_f(); + size = get_locint_f(); + res = get_locint_f(); + loc_a[0] = arg; + loc_a[1] = size; + loc_a[2] = res; +#ifdef computenumbers + val_a[0] = T0[arg]; + val_a[1] = make_nan(); + for (l=0; l + +#ifdef __cplusplus +#include +extern "C" { +#endif + +/****************************************************************************/ +/* USE calloc INSTEAD OF malloc IF NECESSARY */ +/* olvo 20000214: introduced after reported problems with uninitialized + memory calling ADOL-C drivers from FORTRAN on SGI */ +#ifdef USE_CALLOC +#define ADOLC_MALLOC(n,m) calloc(n,m) +#else +#define ADOLC_MALLOC(n,m) malloc(n*m) +#endif + + +/****************************************************************************/ +/* MEMORY MANAGEMENT UTILITIES */ + +/*--------------------------------------------------------------------------*/ +double* myalloc1(int m) +{ double* A = (double*)ADOLC_MALLOC(m,sizeof(double)); + if (A == NULL) + { fprintf(DIAG_OUT,"ADOL-C error: myalloc1 cannot allocate %i bytes\n", + m*sizeof(double)); + exit (-1); + } + return A; +} + +/*--------------------------------------------------------------------------*/ +double** myalloc2(int m, int n) +{ double *Adum = (double*)ADOLC_MALLOC(m*n,sizeof(double)); + double **A = (double**)ADOLC_MALLOC(m,sizeof(double*)); + int i; + if (Adum == NULL) + { fprintf(DIAG_OUT,"ADOL-C error: myalloc2 cannot allocate %i bytes\n", + m*n*sizeof(double)); + exit (-1); + } + if (A == NULL) + { fprintf(DIAG_OUT,"ADOL-C error: myalloc2 cannot allocate %i bytes\n", + m*sizeof(double*)); + exit (-1); + } + for (i=0; i +/****************************************************************************/ +/****************************************************************************/ +/****************************************************************************/ +/* PUBLIC EXPORTS ONLY */ + + +#ifdef __cplusplus +extern "C" { +#endif +/****************************************************************************/ +/****************************************************************************/ +/* Now the C THINGS */ + +/****************************************************************************/ +/* MEMORY MANAGEMENT UTILITIES */ +double *myalloc1(int); +double **myalloc2(int, int); +double ***myalloc3(int, int, int); + +void myfree1(double *); +void myfree2(double **); +void myfree3(double ***); + + +/****************************************************************************/ +/* SPECIAL IDENTITY REPRESENTATION */ +double **myallocI2(int); +void myfreeI2(int, double**); + + +/****************************************************************************/ +/****************************************************************************/ +/* Now the C++ THINGS */ +#ifdef __cplusplus +} + +/****************************************************************************/ +/* MEMORY MANAGEMENT UTILITIES */ +inline double * myalloc(int n) { return myalloc1(n); } +inline double ** myalloc(int m, int n) { return myalloc2(m,n); } +inline double *** myalloc(int m, int n, int p) { return myalloc3(m,n,p); } + +inline void myfree(double *A) { myfree1(A); } +inline void myfree(double **A) { myfree2(A); } +inline void myfree(double ***A) { myfree3(A); } + +/****************************************************************************/ +/* THAT'S ALL */ +#endif + +#endif + diff --git a/adol-c/SRC/adallocC.C b/adol-c/SRC/adallocC.C new file mode 100644 index 0000000..884c66d --- /dev/null +++ b/adol-c/SRC/adallocC.C @@ -0,0 +1,30 @@ +#define _ADALLOCC_CPP_ +#define _ADOLC_SRC_ +/* + -------------------------------------------------------------- + File adallocC.C of ADOL-C version 1.8.3 as of Jun/22/99 + -------------------------------------------------------------- + C++ allocation of arrays of doubles in several dimensions + + Last changes: + 990622 olvo: all made inline, see header + 981130 olvo: newly created. + -------------------------------------------------------------- +*/ + +/****************************************************************************/ +/* INCLUDES */ +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" /* Users Parameters */ +#include "adalloc.h" + + +/****************************************************************************/ +/* MEMORY MANAGEMENT UTILITIES */ + + +/****************************************************************************/ +/* THAT'S ALL*/ +#undef _ADOLC_SRC_ +#undef _ADALLOCC_CPP_ + diff --git a/adol-c/SRC/adolc.h b/adol-c/SRC/adolc.h new file mode 100644 index 0000000..14726d6 --- /dev/null +++ b/adol-c/SRC/adolc.h @@ -0,0 +1,73 @@ +#ifndef _ADOLC_H_ +#define _ADOLC_H_ +/* + ------------------------------------------------------------- + File adutils.h of ADOL-C version 1.8.0 as of Dec/01/98 + ------------------------------------------------------------- + Provides all C/C++ interfaces of ADOL-C. + NOTICE: ALL C/C++ headers will be included DEPENDING ON + whether the source code is plain C or C/C++ code. + + Last changes: + 981201 olvo this new version + + ------------------------------------------------------------- +*/ + +/****************************************************************************/ +/* JUST INCLUDES */ + + +#ifdef __cplusplus +/****************************************************************************/ +/****************************************************************************/ +/* Now the pure C++ THINGS */ + +/*--------------------------------------------------------------------------*/ +/* Operator overloading things (active doubles & vectors) */ +#include "adouble.h" +#include "avector.h" + + +#endif + + +/****************************************************************************/ +/****************************************************************************/ +/* Now the C/C++ THINGS */ + +/*--------------------------------------------------------------------------*/ +/* interfaces to basic forward/reverse routines */ +#include "interfaces.h" + +/*--------------------------------------------------------------------------*/ +/* interfaces to "Easy To Use" driver routines for ... */ +#include "DRIVERS/drivers.h" /* ... optimization & nonlinear equations */ +#include "DRIVERS/taylor.h" /* ... higher order tensors & inverse/implicit + functions */ +#include "DRIVERS/odedrivers.h" /* ... ordinary differential equations */ + +/*--------------------------------------------------------------------------*/ +/* interfaces to TAPEDOC package */ +#include "TAPEDOC/tapedoc.h" + +/*--------------------------------------------------------------------------*/ +/* interfaces to SPARSE package */ +#include "SPARSE/sparse.h" +#include "SPARSE/jacutils.h" + +/*--------------------------------------------------------------------------*/ +/* tape utilities */ +#include "taputil.h" + +/*--------------------------------------------------------------------------*/ +/* allocation utilities */ +#include "adalloc.h" + + +/****************************************************************************/ +/* THAT'S ALL */ +#endif + + + diff --git a/adol-c/SRC/adouble.C b/adol-c/SRC/adouble.C new file mode 100644 index 0000000..d51955e --- /dev/null +++ b/adol-c/SRC/adouble.C @@ -0,0 +1,2605 @@ +#define _ADOUBLE_CPP_ +#define _ADOLC_SRC_ +/* + -------------------------------------------------------------- + File adouble.C of ADOL-C version 1.8.5 as of Dec/10/99 + -------------------------------------------------------------- + adouble.C contains that definitions of procedures used to + define various badouble, adub, asub and adouble operations. + These operations actually have two purposes. + The first purpose is to actual compute the function, just as + the same code written for double precision (single precision - + complex - interval) arithmetic would. The second purpose is + to write a transcript of the computation for the reverse pass + of automatic differentiation. + + Last changes: + 991210 olvo checking the changes + 991122 olvo new op_codes eq_plus_prod eq_min_prod + for y += x1 * x2 + and y -= x1 * x2 + 981130 olvo last check (includes ...) + 981119 olvo changed tanh as J.M. Aparicio suggested + 981020 olvo skip upd_resloc(..) if no tracing performed + 980924 olvo changed all int_* opcodes + 980921 olvo (1) changed save-order in sin/cos + (2) new interface in call to + void overwrite_scaylor(..) which + allows correction of old overwrite in store + 980820 olvo new comparison strategy + 980721 olvo: write of taylors in subscript + 980713 olvo: elimination of "writes" from taputil1.c completed + 980710 olvo sin/cos writes 2 taylors + 980709 olvo: elimination of "writes" from taputil1.c + 980708 olvo: new: write_upd(..) + 980707 olvo: taping with keep + 980706 olvo: new operation code: incr_a + decr_a + 980623 olvo: griewank's idea -- stock manipulation + 980518 olvo: griewank's idea -- write_death(..) killed + 980517 olvo: griewank's idea -- operator: + adouble& adouble::operator = (const adub& a) + + -------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/* INCLUDES */ + +#include "dvlparms.h" +#include "usrparms.h" +#include "adouble.h" +#include "oplate.h" +#include "taputil.h" +#include "tayutil.h" + +#include +#include +#include + + +/****************************************************************************/ +/* HELPFUL FUNCTIONS */ + +/*--------------------------------------------------------------------------*/ +void condassign( double &res, const double &cond, + const double &arg1, const double &arg2 ) +{ res = cond ? arg1 : arg2; +} + +/*--------------------------------------------------------------------------*/ +void condassign( double &res, const double &cond, + const double &arg) +{ res = cond ? arg : res; +} + +/*--------------------------------------------------------------------------*/ +double fmax( const double &x, const double &y ) +{ if (y > x) + return y; + else + return x; +} + +/*--------------------------------------------------------------------------*/ +double fmin( const double &x, const double &y ) +{ if (y < x) + return y; + else + return x; +} + +/****************************************************************************/ +/* GLOBAL VARS */ + +/*--------------------------------------------------------------------------*/ +double* store; // = double stack +int trace_flag = 0; + +/*--------------------------------------------------------------------------*/ +static locint maxloc = sizeof(locint) ==2 ? 65535 : 2147483647; +static locint current_top = 0; // = largest live location + 1 +static locint location_cnt = 0; // = maximal # of lives so far +static locint maxtop = 0; // = current size of store +static locint maxtop2; +static locint dealloc = 0; // = # of locations to be freed +static locint deminloc = 0; // = lowest loc to be freed + + + +/****************************************************************************/ +/* MEMORY MANAGMENT */ + +/*--------------------------------------------------------------------------*/ +/* Return the next free location in "adouble" memory */ +locint next_loc() +{ /* First deallocate dead adoubles if they form a contiguous tail: */ +#ifdef overwrite + if (dealloc && dealloc+deminloc == current_top) + { /* olvo 980518 deleted write_death (see version griewank) */ + // if (trace_flag) + // write_death(deminloc, current_top - 1); + current_top = deminloc ; + dealloc = 0; + deminloc = maxloc; + } +#endif + if (current_top == location_cnt) + ++location_cnt; + if (location_cnt > maxtop) + { maxtop2 = ++maxtop*2 > maxloc ? maxloc : 2*maxtop; + if (maxtop2 == maxloc) + { fprintf(DIAG_OUT,"\nADOL-C error:\n"); + fprintf(DIAG_OUT,"maximal number (%d) of live active variables exceeded\n\n", maxloc); + fprintf(DIAG_OUT,"Possible remedies :\n\n"); + fprintf(DIAG_OUT," 1. Use more automatic local variables and \n"); + fprintf(DIAG_OUT," allocate/deallocate adoubles on free store\n"); + fprintf(DIAG_OUT," in a strictly last in first out fashion\n\n"); + fprintf(DIAG_OUT," 2. Extend the range by redefining the type of \n"); + fprintf(DIAG_OUT," locint (currently %d byte) from unsigned short (%d byte) or int \n", sizeof(locint),sizeof(unsigned short)); + fprintf(DIAG_OUT," to int (%d byte) or long (%d byte). \n",sizeof(int),sizeof(long)); + exit(-3); + } + else + { maxtop = maxtop2; + if (maxtop == 2) + { store = (double *)malloc(maxtop*sizeof(double)); + deminloc = maxloc; + } + else + store = (double *)realloc((char *)store,maxtop*sizeof(double)); + if (store == 0) + { fprintf(DIAG_OUT,"\nADOL-C error:\n"); + fprintf(DIAG_OUT,"Failure to reallocate storage for adouble values\n"); + fprintf(DIAG_OUT,"Possible remedies :\n\n"); + fprintf(DIAG_OUT," 1. Use more automatic local variables and \n"); + fprintf(DIAG_OUT," allocate/deallocate adoubles on free store\n"); + fprintf(DIAG_OUT," in a strictly last in first out fashion\n"); + fprintf(DIAG_OUT," 2. Enlarge your system stacksize limit\n"); + exit(-3); + } + } + } + return current_top++; +} + + +/*--------------------------------------------------------------------------*/ +/* Return the next #size free locations in "adouble" memory */ +locint next_loc( int size ) +{ /* First deallocate dead adoubles if they form a contiguous tail: */ +#ifdef overwrite + if (dealloc && dealloc+deminloc == current_top) + { /* olvo 980518 deleted write_death (see version griewank) */ + // if (trace_flag) + // write_death(deminloc, current_top - 1); + current_top = deminloc ; + dealloc = 0; + deminloc = maxloc; + } +#endif + if ((current_top+size) >= location_cnt) + location_cnt = current_top+size+1; + while (location_cnt > maxtop) + { maxtop2 = ++maxtop*2 > maxloc ? maxloc : 2*maxtop; + if (maxtop2 == maxloc) + { fprintf(DIAG_OUT,"\nADOL-C error: \n"); + fprintf(DIAG_OUT,"maximal number (%d) of live active variables exceeded\n\n", maxloc); + fprintf(DIAG_OUT,"Possible remedies :\n\n"); + fprintf(DIAG_OUT," 1. Use more automatic local variables and \n"); + fprintf(DIAG_OUT," allocate/deallocate adoubles on free store\n"); + fprintf(DIAG_OUT," in a strictly last in first out fashion\n\n"); + fprintf(DIAG_OUT," 2. Extend the range by redefining the type of \n"); + fprintf(DIAG_OUT," locint (currently %d byte) from unsigned short (%d byte) or int \n", sizeof(locint),sizeof(unsigned short)); + fprintf(DIAG_OUT," to int (%d byte) or long (%d byte). \n",sizeof(int),sizeof(long)); + exit(-3); + } + else + { maxtop = maxtop2; + if (maxtop == 2) + { store = (double *)malloc(maxtop*sizeof(double)); + deminloc = maxloc; + } + else + { /* Allocate the storage */ + double *temp; + temp = (double *)malloc(maxtop*sizeof(double)); + if(temp == NULL) + { fprintf(DIAG_OUT,"\nADOL-C error: cannot allocate %i bytes\n",maxtop*sizeof(double)); + exit (-1); + } + /* Copy over storage */ + for (int i=0; i 0) + { put_op(take_stock_op); + put_locint(vals_left); + put_locint(loc); + put_vals_r(vals,vals_left); + } +#endif + trace_flag = 1; +} + +/*--------------------------------------------------------------------------*/ +/* olvo 980623 version griewank */ +locint keep_stock() +{ if (location_cnt > 0) + { // old: write_death(0,location_cnt - 1); + locint loc2 = location_cnt - 1; + + put_op(death_not); + put_locint(0); + put_locint(loc2); + + vs_ptr += location_cnt; + if (revalso) + do + write_scaylor(store[loc2]); + while(loc2-- > 0); + } + trace_flag = 0; + return location_cnt; +} + +/*----------------------------------------------------------------*/ +/* The remaining routines define the badouble,adub,and adouble */ +/* routines. */ +/*----------------------------------------------------------------*/ + +/****************************************************************************/ +/* CONSTRUCTORS */ + +/*--------------------------------------------------------------------------*/ +/* just a comment: +adub::adub( double coval ) +{ location = next_loc(); + + if (trace_flag) + { // old: write_int_assign_d(location,coval); + if (coval == 0) + { put_op(assign_d_zero); + put_locint(location); // = res + } + else + if (coval == 1.0) + { put_op(assign_d_one); + put_locint(location); // = res + } + else + { put_op(assign_d); + put_locint(location); // = res + put_val(coval); // = coval + } + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[res] = coval; +} +*/ + +/*--------------------------------------------------------------------------*/ +adouble::adouble() +{ location = next_loc(); +} + +/*--------------------------------------------------------------------------*/ +adouble::adouble( double coval ) +{ location = next_loc(); + + if (trace_flag) + { // old: write_int_assign_d(location,coval); + if (coval == 0) + { put_op(assign_d_zero); + put_locint(location); // = res + } + else + if (coval == 1.0) + { put_op(assign_d_one); + put_locint(location); // = res + } + else + { put_op(assign_d); + put_locint(location); // = res + put_val(coval); // = coval + } + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location] = coval; +} + +/*--------------------------------------------------------------------------*/ +adouble::adouble( const adouble& a ) +{ location = next_loc(); + + if (trace_flag) + { // old: write_int_assign_a(location,a.location); + put_op(assign_a); + put_locint(a.location); // = arg + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location] = store[a.location]; +} + +/*--------------------------------------------------------------------------*/ +adouble::adouble( const adub& a ) +{ location = next_loc(); + + if (trace_flag) + { // old: write_int_assign_a(location,a.loc()); + put_op(assign_a); + put_locint(a.loc()); // = arg + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location] = store[a.loc()]; +} + +/*--------------------------------------------------------------------------*/ +adouble::adouble( const along& a ) +{ location = next_loc(); + + if (trace_flag) + { // old: write_int_assign_a(location,a.loc()); + put_op(assign_a); + put_locint(a.loc()); // = arg + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location] = store[a.loc()]; +} + +/****************************************************************************/ +/* DESTRUCTORS */ + +#ifdef overwrite +/*--------------------------------------------------------------------------*/ +adouble::~adouble() +{ ++dealloc; + if (location < deminloc) + deminloc = location; +} + +/*--------------------------------------------------------------------------*/ +adub::~adub() +{ ++dealloc; + if (location < deminloc) + deminloc = location; +} + +/*--------------------------------------------------------------------------*/ +asub::~asub() +{ ++dealloc; + if (location < deminloc) + deminloc = location; +} + +/*--------------------------------------------------------------------------*/ +along::~along() +{ ++dealloc; + if (location < deminloc) + deminloc = location; +} +#endif + + +/****************************************************************************/ +/* ASSIGNMENTS */ + +/*--------------------------------------------------------------------------*/ +/* Assign an adouble variable a constant value. */ +badouble& badouble::operator = ( double coval ) +{ if (trace_flag) + { // old: write_assign_d(location,coval); + if (coval == 0) + { put_op(assign_d_zero); + put_locint(location); // = res + } + else + if (coval == 1.0) + { put_op(assign_d_one); + put_locint(location); // = res + } + else + { put_op(assign_d); + put_locint(location); // = res + put_val(coval); // = coval + } + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location] = coval; + return *this; +} + +/*--------------------------------------------------------------------------*/ +/* Assign an adouble variable a constant value. */ +adouble& adouble::operator = ( double coval ) +{ (*this).badouble::operator=(coval); + return (*this); +} + +/*--------------------------------------------------------------------------*/ +/* Assign an adouble variable to an independent value. */ +badouble& badouble::operator <<= ( double coval ) +{ if (trace_flag) + { // old: write_assign_ind(location); + ind_ptr++; + + put_op(assign_ind); + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location] = coval; + return *this; +} + +/*--------------------------------------------------------------------------*/ +/* Assign a float variable from a dependent adouble value. */ +badouble& badouble::operator >>= ( double& coval ) +{ if (trace_flag) + { // old: write_assign_dep(location); + dep_ptr++; + + put_op(assign_dep); + put_locint(location); // = res + } + + coval = double (store[location]); + return *this; +} + +/*--------------------------------------------------------------------------*/ +/* Assign an Badouble variable an Badouble value. */ +badouble& badouble::operator = ( const badouble& x ) +{ locint x_loc = x.loc(); + if (location!=x_loc) + /* test this to avoid for x=x statements adjoint(x)=0 in reverse mode */ + { if (trace_flag) + { // old: write_assign_a(location,x.location); + put_op(assign_a); + put_locint(x_loc); // = arg + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location]=store[x_loc]; + } + return *this; +} + +/*--------------------------------------------------------------------------*/ +/* Assign an Badouble variable an Badouble value. */ +adouble& adouble::operator = ( const badouble& x ) +{ (*this).badouble::operator=(x); + return (*this); +} + +/*--------------------------------------------------------------------------*/ +/* Assign an adouble an adub */ +/* olvo 980517 new version griewank */ +badouble& badouble::operator = ( const adub& a ) +{ locint a_loc = a.loc(); + int upd = 0; + /* 981020 olvo skip upd_resloc(..) if no tracing performed */ + if (trace_flag) + upd = upd_resloc(a_loc,location); + if (upd) + { /* olvo 980708 new n2l & 980921 changed interface */ + revreal tempVal = store[a_loc]; + if (revalso) + overwrite_scaylor(store[location],&store[a_loc]); + if (a_loc == current_top-1) + { current_top--; // The temporary will die in a minute and + dealloc--; // by reducing dealloc and current_top + } // we neutralize that effect + store[location] = tempVal; + } + else + { if (trace_flag) + { // old: write_assign_a(location,a_loc); + put_op(assign_a); + put_locint(a_loc); // = arg + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + store[location] = store[a_loc]; + } + + return *this; +} + +/*--------------------------------------------------------------------------*/ +/* Assign an adouble an adub */ +/* olvo 980517 new version griewank */ +adouble& adouble::operator = ( const adub& a ) +{ (*this).badouble::operator=(a); + return (*this); +} + + +/****************************************************************************/ +/* INPUT / OUTPUT */ + +/*--------------------------------------------------------------------------*/ +/* Output an adouble value !!! No tracing of this action */ +ostream& operator << ( ostream& out, const badouble& y ) +{ return out << store[y.location] << "(a)" ; +} + +/*--------------------------------------------------------------------------*/ +/* Input adouble value */ +istream& operator >> ( istream& in, const badouble& y ) +{ double coval; + in >> coval; + if (trace_flag) + { // old: write_assign_d(y.location,coval); + if (coval == 0) + { put_op(assign_d_zero); + put_locint(y.location); // = res + } + else + if (coval == 1.0) + { put_op(assign_d_one); + put_locint(y.location); // = res + } + else + { put_op(assign_d); + put_locint(y.location); // = res + put_val(coval); // = coval + } + + ++vs_ptr; + if (revalso) + write_scaylor(store[y.location]); + } + + store[y.location] = coval; + return in; +} + +/****************************************************************************/ +/* INCREMENT / DECREMENT */ + +/*--------------------------------------------------------------------------*/ +/* Postfix increment */ +adub adouble::operator++( int ) +{ locint locat = next_loc(); + + if (trace_flag) + { // old: write_assign_a(locat,location); + put_op(assign_a); + put_locint(location); // = arg + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat]=store[location]; + + if (trace_flag) + { // old: write_incr_decr_a(incr_a,location); + put_op(incr_a); + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location]++; + return locat; +} + +/*--------------------------------------------------------------------------*/ + /* Postfix decrement */ +adub adouble::operator--( int ) +{ locint locat = next_loc(); + + if (trace_flag) + { // old: write_assign_a(locat,location); + put_op(assign_a); + put_locint(location); // = arg + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat]=store[location]; + if (trace_flag) + { // old: write_incr_decr_a(decr_a,location); + put_op(decr_a); + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location]--; + return locat; +} + +/*--------------------------------------------------------------------------*/ + /* Prefix increment */ +badouble& adouble::operator++() +{ if (trace_flag) + { // old: write_incr_decr_a(incr_a,location); + put_op(incr_a); + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location]++; + return *this; +} + +/*--------------------------------------------------------------------------*/ +/* Prefix decrement */ +badouble& adouble::operator--() +{ if (trace_flag) + { // old: write_incr_decr_a(decr_a,location); + put_op(decr_a); + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location]--; + return *this; +} + +/****************************************************************************/ +/* OPERATION + ASSIGNMENT */ + +/*--------------------------------------------------------------------------*/ +/* Adding a floating point to an adouble */ +badouble& badouble::operator += ( double coval ) +{ if (trace_flag) + { // old: write_d_same_arg(eq_plus_d,location,coval); + put_op(eq_plus_d); + put_locint(location); // = res + put_val(coval); // = coval + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location] += coval; + return *this; +} + + +/*--------------------------------------------------------------------------*/ +/* Subtracting a floating point from an adouble */ +badouble& badouble::operator -= ( double coval ) +{ if (trace_flag) + { // old: write_d_same_arg(eq_min_d,location,coval); + put_op(eq_min_d); + put_locint(location); // = res + put_val(coval); // = coval + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location] -= coval; + return *this; +} + +/*--------------------------------------------------------------------------*/ +/* Add an adouble to another adouble */ +badouble& badouble::operator += ( const badouble& y ) +{ locint y_loc = y.loc(); + if (trace_flag) + { // old: write_a_same_arg(eq_plus_a,location,y.location); + put_op(eq_plus_a); + put_locint(y_loc); // = arg + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location] += store[y_loc]; + return *this; +} + +/*--------------------------------------------------------------------------*/ +/* olvo 991122 new version for y += x1 * x2; */ +badouble& badouble::operator += ( const adub& a ) +{ locint a_loc = a.loc(); + int upd = 0; + if (trace_flag) + upd = upd_resloc_inc_prod(a_loc,location,eq_plus_prod); + if (upd) + { store[location] += store[a_loc]; + if (revalso) + delete_scaylor(&store[a_loc]); + if (a_loc == current_top-1) + { current_top--; // The temporary will die in a minute and + dealloc--; // by reducing dealloc and current_top + } // we neutralize that effect + --vs_ptr; + } + else + { if (trace_flag) + { // old: write_assign_a(location,a_loc); + put_op(eq_plus_a); + put_locint(a_loc); // = arg + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + store[location] += store[a_loc]; + } + + return *this; +} + +/*--------------------------------------------------------------------------*/ +/* Subtract an adouble from another adouble */ +badouble& badouble::operator -= ( const badouble& y ) +{ locint y_loc = y.loc(); + if (trace_flag) + { // old: write_a_same_arg(eq_min_a,location,y.location); + put_op(eq_min_a); + put_locint(y_loc); // = arg + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location] -= store[y_loc]; + return *this; +} + +/*--------------------------------------------------------------------------*/ +/* olvo 991122 new version for y -= x1 * x2; */ +badouble& badouble::operator -= ( const adub& a ) +{ locint a_loc = a.loc(); + int upd = 0; + if (trace_flag) + upd = upd_resloc_inc_prod(a_loc,location,eq_min_prod); + if (upd) + { store[location] -= store[a_loc]; + if (revalso) + delete_scaylor(&store[a_loc]); + if (a_loc == current_top-1) + { current_top--; // The temporary will die in a minute and + dealloc--; // by reducing dealloc and current_top + } // we neutralize that effect + --vs_ptr; + } + else + { if (trace_flag) + { // old: write_assign_a(location,a_loc); + put_op(eq_min_a); + put_locint(a_loc); // = arg + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + store[location] -= store[a_loc]; + } + + return *this; +} + +/*--------------------------------------------------------------------------*/ +/* Multiply an adouble by a floating point */ +badouble& badouble::operator *= ( double coval ) +{ if (trace_flag) + { // old: write_d_same_arg(eq_mult_d,location,coval); + put_op(eq_mult_d); + put_locint(location); // = res + put_val(coval); // = coval + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location] *= coval; + return *this; +} + +/*--------------------------------------------------------------------------*/ +/* Multiply one adouble by another adouble*/ +badouble& badouble::operator *= ( const badouble& y ) +{ locint y_loc = y.loc(); + if (trace_flag) + { // old: write_a_same_arg(eq_mult_a,location,y.location); + put_op(eq_mult_a); + put_locint(y_loc); // = arg + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location] *= store[y_loc]; + return *this; +} + +/*--------------------------------------------------------------------------*/ +badouble& badouble::operator /= (double y) +{ *this = *this/y; + return *this; +} + +/*--------------------------------------------------------------------------*/ +badouble& badouble::operator /= (const badouble& y) +{ *this = *this * (1.0/y); + return *this; +} + +/****************************************************************************/ +/* COMPARISON */ +/* olvo 980819 NOTE: new comparison strategy !!! */ + +/*--------------------------------------------------------------------------*/ +/* The Not Equal Operator (!=) */ +int operator != ( const badouble& v, double coval ) +{ if (coval) + return (-coval+v != 0); + else + { if (trace_flag) + { put_op(store[v.location] ? neq_zero : eq_zero); + put_locint(v.location); + } + return (store[v.location] != 0); + } +} + +/*--------------------------------------------------------------------------*/ +/* The Equal Operator (==) */ +int operator == ( const badouble& v, double coval) +{ if (coval) + return (-coval+v == 0); + else + { if (trace_flag) + { put_op(store[v.location] ? neq_zero : eq_zero); + put_locint(v.location); + } + return (store[v.location] == 0); + } +} + +/*--------------------------------------------------------------------------*/ +/* The Less than or Equal Operator (<=) */ +int operator <= ( const badouble& v, double coval ) +{ if (coval) + return (-coval+v <= 0); + else + { int b = (store[v.location] <= 0); + if (trace_flag) + { put_op(b ? le_zero : gt_zero); + put_locint(v.location); + } + return b; + } +} + +/*--------------------------------------------------------------------------*/ +/* The Greater than or Equal Operator (>=) */ +int operator >= ( const badouble& v, double coval ) +{ if (coval) + return (-coval+v >= 0); + else + { int b = (store[v.location] >= 0); + if (trace_flag) + { put_op(b ? ge_zero : lt_zero); + put_locint(v.location); + } + return b; + } +} + +/*--------------------------------------------------------------------------*/ +/* The Greater than Operator (>) */ +int operator > ( const badouble& v, double coval ) +{ if (coval) + return (-coval+v > 0); + else + { int b = (store[v.location] > 0); + if (trace_flag) + { put_op(b ? gt_zero : le_zero); + put_locint(v.location); + } + return b; + } +} + +/*--------------------------------------------------------------------------*/ +/* The Less than Operator (<) */ +int operator < ( const badouble& v, double coval ) +{ if (coval) + return (-coval+v < 0); + else + { int b = (store[v.location] < 0); + if (trace_flag) + { put_op(b ? lt_zero : ge_zero); + put_locint(v.location); + } + return b; + } +} + + +/****************************************************************************/ +/* SIGN OPERATORS */ + +/*--------------------------------------------------------------------------*/ +/* olvo 980709 modified positive sign operator + ??? possibly there is a better way */ +adub operator + ( const badouble& x ) +{ locint locat = next_loc(); + + if (trace_flag) + { // old: write_pos_sign_a(locat,x.location); + put_op(pos_sign_a); + put_locint(x.location); // = arg + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = store[x.location]; + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* olvo 980709 modified negative sign operator */ +adub operator - ( const badouble& x ) +{ locint locat = next_loc(); + + if (trace_flag) + { // old: write_neg_sign_a(locat,x.location); + put_op(neg_sign_a); + put_locint(x.location); // = arg + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = -store[x.location]; + return locat; +} + + +/****************************************************************************/ +/* BINARY OPERATORS */ + +/* NOTE: each operator calculates address of temporary and returns + an adub */ + +/*--------------------------------------------------------------------------*/ +/* Adding two adoubles */ +adub operator + ( const badouble& x, const badouble& y ) +{ locint locat = next_loc(); + + if (trace_flag) + { // old: write_two_a_rec(plus_a_a,locat,x.location,y.location); + put_op(plus_a_a); + put_locint(x.location); // = arg1 + put_locint(y.location); // = arg2 + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = store[x.location] + store[y.location]; + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* Adding a adouble and a floating point */ +adub operator + ( double coval, const badouble& y ) +{ locint locat = next_loc(); + + /* olvo 980708 test coval to be zero */ + if (coval) + { if (trace_flag) + { // old: write_args_d_a(plus_d_a,locat,coval,y.location); + put_op(plus_d_a); + put_locint(y.location); // = arg + put_locint(locat); // = res + put_val(coval); // = coval + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = coval + store[y.location]; + } + else + { if (trace_flag) + { // old: write_pos_sign_a(locat,y.location); + put_op(pos_sign_a); + put_locint(y.location); // = arg + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = store[y.location]; + } + + return locat; +} + +/*--------------------------------------------------------------------------*/ +adub operator + ( const badouble& y, double coval) +{ locint locat = next_loc(); + + /* olvo 980708 test coval to be zero */ + if (coval) + { if (trace_flag) + { // old: write_args_d_a(plus_d_a,locat,coval,y.location); + put_op(plus_d_a); + put_locint(y.location); // = arg + put_locint(locat); // = res + put_val(coval); // = coval + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = coval + store[y.location]; + } + else + { if (trace_flag) + { // old: write_pos_sign_a(locat,y.location); + put_op(pos_sign_a); + put_locint(y.location); // = arg + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = store[y.location]; + } + + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* Subtraction of two adoubles */ +adub operator - ( const badouble& x, const badouble& y ) +{ locint locat = next_loc(); + + if (trace_flag) + { // old: write_two_a_rec(min_a_a,locat,x.location,y.location); + put_op(min_a_a); + put_locint(x.location); // = arg1 + put_locint(y.location); // = arg2 + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = store[x.location] - store[y.location]; + return locat; +} + + +/*--------------------------------------------------------------------------*/ +/* Subtract an adouble from a floating point */ +adub operator - ( double coval, const badouble& y ) +{ locint locat = next_loc(); + + /* olvo 980708 test coval to be zero */ + if (coval) + { if (trace_flag) + { // old: write_args_d_a(min_d_a,locat,coval,y.location); + put_op(min_d_a); + put_locint(y.location); // = arg + put_locint(locat); // = res + put_val(coval); // = coval + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = coval - store[y.location]; + } + else + { if (trace_flag) + { // old: write_neg_sign_a(locat,y.location); + put_op(neg_sign_a); + put_locint(y.location); // = arg + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = -store[y.location]; + } + + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* Multiply two adoubles */ +adub operator * ( const badouble& x, const badouble& y ) +{ locint locat = next_loc(); + + if (trace_flag) + { // old: write_two_a_rec(mult_a_a,locat,x.location,y.location); + put_op(mult_a_a); + put_locint(x.location); // = arg1 + put_locint(y.location); // = arg2 + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = store[x.location] * store[y.location]; + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* Multiply an adouble by a floating point */ +/* olvo 980709 modified */ +adub operator * ( double coval, const badouble& y ) +{ locint locat = next_loc(); + + if ( coval == 1.0 ) + { if (trace_flag) + { // old: write_pos_sign_a(locat,y.location); + put_op(pos_sign_a); + put_locint(y.location); // = arg + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = store[y.location]; + } + else + if ( coval == -1.0 ) + { if (trace_flag) + { // old: write_neg_sign_a(locat,y.location); + put_op(neg_sign_a); + put_locint(y.location); // = arg + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = -store[y.location]; + } + else + { if (trace_flag) + { // old: write_args_d_a(mult_d_a,locat,coval,y.location); + put_op(mult_d_a); + put_locint(y.location); // = arg + put_locint(locat); // = res + put_val(coval); // = coval + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = coval * store[y.location]; + } + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* Divide an adouble by another adouble */ +adub operator / ( const badouble& x, const badouble& y ) +{ locint locat = next_loc(); + + if (trace_flag) + { // old: write_two_a_rec(div_a_a,locat,x.location,y.location); + put_op(div_a_a); + put_locint(x.location); // = arg1 + put_locint(y.location); // = arg2 + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = store[x.location] / store[y.location]; + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* Division floating point - adouble */ +adub operator / ( double coval, const badouble& y ) +{ locint locat = next_loc(); + + if (trace_flag) + { // old: write_args_d_a(div_d_a,locat,coval,y.location); + put_op(div_d_a); + put_locint(y.location); // = arg + put_locint(locat); // = res + put_val(coval); // = coval + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = coval / store[y.location]; + return locat; +} + + +/****************************************************************************/ +/* SINGLE OPERATIONS */ + +/*--------------------------------------------------------------------------*/ +/* Compute exponential of adouble */ +adub exp ( const badouble& x ) +{ locint locat = next_loc(); + + if (trace_flag) + { // old: write_single_op(exp_op,locat,x.location); + put_op(exp_op); + put_locint(x.location); // = arg + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = exp(store[x.location]); + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* Compute logarithm of adouble */ +adub log ( const badouble& x ) +{ locint locat = next_loc(); + + if (trace_flag) + { // old: write_single_op(log_op,locat,x.location); + put_op(log_op); + put_locint(x.location); // = arg + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = log(store[x.location]); + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* Compute sqrt of adouble */ +adub sqrt ( const badouble& x ) +{ locint locat = next_loc(); + + if (trace_flag) + { // old: write_single_op(sqrt_op,locat,x.location); + put_op(sqrt_op); + put_locint(x.location); // = arg + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = sqrt(store[x.location]); + return locat; +} + +/****************************************************************************/ +/* QUAD OPERATIONS */ + +/*--------------------------------------------------------------------------*/ +/* Compute sin of adouble + !!! Sin and Cos are always evaluated together +*/ +adub sin ( const badouble& x ) +{ locint locat = next_loc(); + + adouble y; + + if (trace_flag) + { // old: write_quad(sin_op,locat,x.location,y.location); + put_op(sin_op); + put_locint(x.location); // = arg1 + put_locint(y.location); // = arg2 + put_locint(locat); // = res + + vs_ptr += 2; + if (revalso) + { /* olvo 980921 changed order */ + write_scaylor(store[y.location]); + write_scaylor(store[locat]); + } + } + + store[locat] = sin(store[x.location]); + store[y.location] = cos(store[x.location]); + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* Compute cos of adouble */ +adub cos ( const badouble& x ) +{ locint locat = next_loc(); + + adouble y; + + if (trace_flag) + { // old: write_quad(cos_op, locat,x.location,y.location); + put_op(cos_op); + put_locint(x.location); // = arg1 + put_locint(y.location); // = arg2 + put_locint(locat); // = res + + vs_ptr += 2; + if (revalso) + { /* olvo 980921 changed order */ + write_scaylor(store[y.location]); + write_scaylor(store[locat]); + } + } + + store[locat] = cos(store[x.location]); + store[y.location] = sin(store[x.location]); + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* Compute tan of adouble */ +adub tan ( const badouble& x ) +{ return sin(x) / cos(x); +} + +/*--------------------------------------------------------------------------*/ +/* Asin value -- really a quadrature */ +adub asin ( const badouble& x ) +{ locint locat = next_loc(); + + adouble y = 1.0 / sqrt(1.0 - x*x); + + if (trace_flag) + { // old: write_quad(asin_op,locat,x.location,y.location); + put_op(asin_op); + put_locint(x.location); // = arg1 + put_locint(y.location); // = arg2 + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = asin(store[x.location]); + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* Acos value -- really a quadrature */ +adub acos ( const badouble& x ) +{ locint locat = next_loc(); + + adouble y = -1.0 / sqrt(1.0 - x*x); + + if (trace_flag) + { // old: write_quad(acos_op,locat,x.location,y.location); + put_op(acos_op); + put_locint(x.location); // = arg1 + put_locint(y.location); // = arg2 + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = acos(store[x.location]); + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* Atan value -- really a quadrature */ +adub atan ( const badouble& x ) +{ locint locat = next_loc(); + + adouble y = 1.0 / (1.0 + x*x); + + if (trace_flag) + { // old: write_quad(atan_op,locat,x.location,y.location); + put_op(atan_op); + put_locint(x.location); // = arg1 + put_locint(y.location); // = arg2 + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = atan(store[x.location]); + return locat; +} + +/*--------------------------------------------------------------------------*/ +adouble atan2( const badouble& y, const badouble& x) +{ adouble a1, a2, ret, sy; + const double pihalf = asin(1.0); + /* y+0.0 is a hack since condassign is currently not defined for + badoubles */ + condassign( sy, y+0.0, 1.0 , -1.0 ); + condassign( a1, x+0.0, (adouble) atan(y/x), + (adouble)( atan(y/x)+sy*2*pihalf)); + condassign( a2, (adouble) fabs(y), (adouble) (sy*pihalf-atan(x/y)), + (adouble) 0.0 ); + condassign( ret, (adouble) (fabs(x) - fabs(y)), a1, a2 ); + return ret; +} + +/*--------------------------------------------------------------------------*/ +/* power value -- adouble ^ floating point */ +adub pow ( const badouble& x, double coval ) +{ locint locat = next_loc(); + + if (trace_flag) + { // old: write_args_d_a(pow_op,locat,cocval,x.location); + put_op(pow_op); + put_locint(x.location); // = arg + put_locint(locat); // = res + put_val(coval); // = coval + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = pow(store[x.location],coval); + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* power value --- floating point ^ adouble */ +adouble pow ( double coval, const badouble& y ) +{ adouble ret; + + if (coval <= 0) + { fprintf(DIAG_OUT,"\nADOL-C message: exponent at zero/negative constant basis deactivated\n"); + } + + condassign (ret, coval, exp(y*log(coval)), pow(coval,value(y)) ); + + return ret; +} + +/*--------------------------------------------------------------------------*/ +/* power value --- adouble ^ adouble */ +adouble pow ( const badouble& x, const badouble& y) +{ adouble a1, a2, ret; + double vx = value(x); + double vy = value(y); + + if (!(vx > 0)) + if (vx < 0 || vy >= 0) + fprintf(DIAG_OUT,"\nADOL-C message: exponent of zero/negative basis deactivated\n"); + else + fprintf(DIAG_OUT,"\nADOL-C message: negative exponent and zero basis deactivated\n"); + + condassign(a1,-y,pow(vx,vy),pow(x,vy)); + condassign(a2,fabs(x),pow(x, vy),a1); + condassign(ret,x+0.0,exp(y*log(x)),a2); + + return ret; +} + +/*--------------------------------------------------------------------------*/ +/* log base 10 of an adouble */ +adub log10 ( const badouble& x ) +{ return log(x) / log(10.0); +} + +/*--------------------------------------------------------------------------*/ +/* Hyperbolic Sine of an adouble */ +/* 981119 olvo changed as J.M. Aparicio suggested */ +adub sinh ( const badouble& x ) +{ if (value(x) < 0.0) + { adouble temp = exp(x); + return 0.5*(temp - 1.0/temp); + } + else + { adouble temp = exp(-x); + return 0.5*(1.0/temp - temp); + } +} + +/*--------------------------------------------------------------------------*/ +/* Hyperbolic Cosine of an adouble */ +/* 981119 olvo changed as J.M. Aparicio suggested */ +adub cosh ( const badouble& x ) +{ adouble temp = (value(x) < 0.0) ? exp(x) : exp(-x); + return 0.5*(temp + 1.0/temp); +} + +/*--------------------------------------------------------------------------*/ +/* + Hyperbolic Tangent of an adouble value. +*/ +/* 981119 olvo changed as J.M. Aparicio suggested */ +adub tanh ( const badouble& x ) +{ if (value(x) < 0.0) + { adouble temp = exp(2.0*x); + return (temp - 1.0)/(temp + 1.0); + } + else + { adouble temp = exp((-2.0)*x); + return (1.0 - temp)/(temp + 1.0); + } +} + +/*--------------------------------------------------------------------------*/ +/* Ceiling function (NOTE: This function is nondifferentiable) */ +adub ceil ( const badouble& x ) +{ locint locat=next_loc(); + + double coval = ceil(store[x.location]); + + if (trace_flag) + { // old: write_args_d_a(ceil_op,locat,coval,x.location); + put_op(ceil_op); + put_locint(x.location); // = arg + put_locint(locat); // = res + put_val(coval); // = coval + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = coval; + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* Floor function (NOTE: This function is nondifferentiable) */ +adub floor ( const badouble& x ) +{ locint locat=next_loc(); + + double coval = floor(store[x.location]); + + if (trace_flag) + { // old: write_args_d_a(floor_op,locat,coval,x.location); + put_op(floor_op); + put_locint(x.location); // = arg + put_locint(locat); // = res + put_val(coval); // = coval + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = coval; + return locat; +} + +#ifdef ATRIG_ERF +/* NOTE: enable if your compiler knows asinh, acosh, atanh, erf */ + +/*--------------------------------------------------------------------------*/ +/* Asinh value -- really a quadrature */ +adub asinh ( const badouble& x ) +{ locint locat = next_loc(); + + adouble y = 1.0 / sqrt(1.0 + x*x); + + if (trace_flag) + { // old: write_quad(asinh_op,locat,x.location,y.location); + put_op(asinh_op); + put_locint(x.location); // = arg1 + put_locint(y.location); // = arg2 + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = asinh(store[x.location]); + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* Acosh value -- really a quadrature */ +adub acosh ( const badouble& x ) +{ locint locat = next_loc(); + + adouble y = 1.0 / sqrt(1.0 - x*x); + + if (trace_flag) + { // old: write_quad(acosh_op,locat,x.location,y.location); + put_op(acosh_op); + put_locint(x.location); // = arg1 + put_locint(y.location); // = arg2 + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = acosh(store[x.location]); + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* Atanh value -- really a quadrature */ +adub atanh ( const badouble& x ) +{ locint locat = next_loc(); + + adouble y = 1.0 / (1.0 - x*x); + + if (trace_flag) + { // old: write_quad(atanh_op,locat,x.location,y.location); + put_op(atanh_op); + put_locint(x.location); // = arg1 + put_locint(y.location); // = arg2 + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat] = atanh(store[x.location]); + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* The error function erf */ +adub erf( const badouble& x ) +{ locint locat = next_loc(); + + adouble y = exp(-x*x); + + if (trace_flag) + { // old: write_quad(erf_op,locat,x.location,y.location); + put_op(erf_op); + put_locint(x.location); // = arg1 + put_locint(y.location); // = arg2 + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat]=erf(store[x.location]); + return locat; +} + +#endif + +/*--------------------------------------------------------------------------*/ +/* Fabs Function (NOTE: This function is also nondifferentiable at x=0) */ +adub fabs ( const badouble& x ) +{ locint locat = next_loc(); + + double coval = 1.0; + double temp = fabs(store[x.location]); + if (temp != store[x.location]) + coval = 0.0; + + if (trace_flag) + { /* write_args_d_a(abs_val,locat,coval,x.location); */ + put_op(abs_val); + put_locint(x.location); /* arg */ + put_locint(locat); /* res */ + put_val(coval); /* coval */ + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + store[locat] = temp; + return locat; +} + +/*--------------------------------------------------------------------------*/ +/* max and min functions (changed : 11/15/95) */ +adub fmin ( const badouble& x, const badouble& y ) +{ /* olvo 980702 tested: return 0.5*fabs(x+y-fabs(x-y)); */ + locint locat = next_loc(); + + if (store[y.location] < store[x.location]) + { if (trace_flag) + { // old: write_min_op(x.location,y.location,locat,0.0); + put_op(min_op); + put_locint(x.location); // = arg1 + put_locint(y.location); // = arg2 + put_locint(locat); // = res + put_val(0.0); // = coval + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat]=store[y.location]; + } + else + { if (trace_flag) + { // old: write_min_op(x.location,y.location,locat,1.0); + put_op(min_op); + put_locint(x.location); // = arg1 + put_locint(y.location); // = arg2 + put_locint(locat); // = res + put_val(1.0); // = coval + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat]=store[x.location]; + } + return locat; +} + +/*--------------------------------------------------------------------------*/ +/*21.8.96*/ +adub fmin ( double d, const badouble& y ) +{ adouble x = d; + return (fmin (x,y)); +} + +/*--------------------------------------------------------------------------*/ +adub fmin ( const badouble& x, double d ) +{ adouble y = d; + return (fmin (x,y)); +} + +/*--------------------------------------------------------------------------*/ +adub fmax ( const badouble& x, const badouble& y ) +{ return (-fmin(-x,-y)); +} + +/*--------------------------------------------------------------------------*/ +/*21.8.96*/ +adub fmax ( double d, const badouble& y ) +{ adouble x = d; + return (-fmin(-x,-y)); +} + +/*--------------------------------------------------------------------------*/ +adub fmax ( const badouble& x, double d ) +{ adouble y = d; + return (-fmin(-x,-y)); +} + +/*--------------------------------------------------------------------------*/ +/* Ldexp Function */ +adub ldexp ( const badouble& x, int exp ) +{ return x*ldexp(1.0,exp); +} + +/*--------------------------------------------------------------------------*/ +/* Macro for user defined quadratures, example myquad is below.*/ +/* the forward sweep tests if the tape is executed exactly at */ +/* the same argument point otherwise it stops with a returnval */ +#define extend_quad(func,integrand)\ +adouble func ( const badouble& arg )\ +{ adouble temp; \ + adouble val; \ + integrand; \ + if (trace_flag) \ + { put_op(gen_quad); \ + put_locint(arg.location); \ + put_locint(val.location); \ + put_locint(temp.location); \ + ++vs_ptr; \ + if (revalso) \ + write_scaylor(store[temp.location]); \ + } \ + store[temp.location]=func(store[arg.location]); \ + if (trace_flag) \ + { put_val(store[arg.location]); \ + put_val(store[temp.location]); \ + } \ + return temp; } + +double myquad(double& x) +{ + double res; + res = log(x); + return res; +} + +/* This defines the natural logarithm as a quadrature */ + +extend_quad(myquad,val = 1/arg) + + +/****************************************************************************/ +/* CONDITIONALS */ + +/* For the time being condassign is defined using adoubles in two + versions with adouble and along as left hand side. This implies + some problems when badoubles are used as arguments, e.g. inside + the pow definition. For later versions we will replace this with + complete definition for all parameter type constellations */ + +/*--------------------------------------------------------------------------*/ +void condassign( adouble &res, const adouble &cond, + const adouble &arg1, const adouble &arg2 ) +{ if (trace_flag) + { // old: write_condassign(res.location,cond.location,arg1.location, + // arg2.location); + put_op(cond_assign); + put_locint(cond.location); // = arg + put_val(store[cond.location]); + put_locint(arg1.location); // = arg1 + put_locint(arg2.location); // = arg2 + put_locint(res.location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[res.location]); + } + + if (store[cond.location] > 0) + store[res.location] = store[arg1.location]; + else + store[res.location] = store[arg2.location]; +} + +/*--------------------------------------------------------------------------*/ +void condassign( adouble &res, const adouble &cond, const adouble &arg ) +{ if (trace_flag) + { // old: write_condassign2(res.location,cond.location,arg.location); + put_op(cond_assign_s); + put_locint(cond.location); // = arg + put_val(store[cond.location]); + put_locint(arg.location); // = arg1 + put_locint(res.location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[res.location]); + } + + if (store[cond.location] > 0) + store[res.location] = store[arg.location]; +} + +/*--------------------------------------------------------------------------*/ +void condassign( along &res, const adouble &cond, + const adouble &arg1, const adouble &arg2 ) +{ if (trace_flag) + { // old: write_condassign(res.location,cond.location,arg1.location, + // arg2.location); + put_op(cond_assign); + put_locint(cond.location); // = arg + put_val(store[cond.location]); + put_locint(arg1.location); // = arg1 + put_locint(arg2.location); // = arg2 + put_locint(res.location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[res.location]); + } + + if (store[cond.location] > 0) + store[res.location] = store[arg1.location]; + else + store[res.location] = store[arg2.location]; +} + +/*--------------------------------------------------------------------------*/ +void condassign( along &res, const adouble &cond, const adouble &arg) +{ if (trace_flag) + { // old: write_condassign2(res.location,cond.location,arg.location); + put_op(cond_assign_s); + put_locint(cond.location); // = arg + put_val(store[cond.location]); + put_locint(arg.location); // = arg1 + put_locint(res.location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[res.location]); + } + + if (store[cond.location] > 0) + store[res.location] = store[arg.location]; +} + +/****************************************************************************/ +/* SUBSCRIPTS (CONSTRUCTOR / ASSIGNMENTS) */ + +/*--------------------------------------------------------------------------*/ +asub::asub(locint start, locint index) +{ +#ifdef DEBUG + fprintf(DIAG_OUT,"\nADOL-C debug: Constructing an asub with 2 arguments\n"); +#endif + base = start; + offset = index; + + location = next_loc(); + + if (trace_flag) + { // old:write_associating_value(subscript,location,base,offset); + put_op(subscript); + put_locint(base); + put_locint(offset); + put_locint(location); + put_val(store[offset]); + + /* olvo 980721 new n3l */ + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location] = store[base+(int)store[offset]]; +} + +/*--------------------------------------------------------------------------*/ +asub& asub::operator <<= ( double coval ) +{ locint res = base+(int)store[offset]; + + if (trace_flag) + { // old: write_assign_ind(location); + ind_ptr++; + put_op(assign_ind); + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + + /* olvo 980711 necessary ??? + } + store[location] = coval; + if (trace_flag) + { */ + + // old: write_associating_value(subscript_l,location,base,offset); + put_op(subscript_l); + put_locint(base); + put_locint(offset); + put_locint(location); + put_val(store[offset]); + + ++vs_ptr; + if (revalso) /* olvo 980711 ??? next line */ + write_scaylor(store[location]); + /* this is correct since location is the location of the copy which + already contains the value to be stored */ + } + + store[res] = coval; + return *this; +} + +/*--------------------------------------------------------------------------*/ +asub& asub::operator = ( double coval ) +{ locint res = base+(int)store[offset]; + + if (trace_flag) + { // old: write_associating_value_ld(subscript_ld,coval,base,offset); + put_op(subscript_ld); + put_val(coval); + put_locint(base); + put_locint(offset); + put_val(store[offset]); + + ++vs_ptr; + if (revalso) + write_scaylor(store[res]); + } + + store[res] = coval; + return *this; +} + +/*--------------------------------------------------------------------------*/ +asub& asub::operator = ( const badouble& x ) +{ locint res = base+(int)store[offset]; + + if (trace_flag) + { // old: write_associating_value(subscript_l,x.loc(),base,offset); + put_op(subscript_l); + put_locint(base); + put_locint(offset); + put_locint(x.loc()); + put_val(store[offset]); + + ++vs_ptr; + if (revalso) /* olvo 980711 ??? next line */ + write_scaylor(store[x.loc()]); + /* this is correct since location is the location of the copy which + already contains the value to be stored */ + } + + store[res]=store[x.loc()]; + return *this; +} + +/*--------------------------------------------------------------------------*/ +/* 20.08.96 */ +asub& asub::operator = ( const asub& x ) +{ locint res = base+(int)store[offset]; + + if (trace_flag) + { // : write_associating_value(subscript_l,x.loc(),base,offset); + put_op(subscript_l); + put_locint(base); + put_locint(offset); + put_locint(x.loc()); + put_val(store[offset]); + + ++vs_ptr; + if (revalso) /* olvo 980711 ??? next line */ + write_scaylor(store[x.loc()]); + /* this is correct since location is the location of the copy which + already contains the value to be stored */ + } + + store[res]=store[x.loc()]; + return *this; +} + + +/****************************************************************************/ +/* SUBSCRIPTS (OPERATION + ASSIGNMENT) */ + +/* olvo 980713 !!! seems to be a temporary version */ + +/*--------------------------------------------------------------------------*/ +/* Sep/01/96 */ +asub& asub::operator += ( double x ) +{ *this = *this + x; + return *this; +} + +/*--------------------------------------------------------------------------*/ +asub& asub::operator += ( const badouble& x ) +{ *this = *this + x; + return *this; +} + +/*--------------------------------------------------------------------------*/ +asub& asub::operator -= ( double x ) +{ *this = *this - x; + return *this; +} + +/*--------------------------------------------------------------------------*/ +asub& asub::operator -= ( const badouble& x ) +{ *this = *this - x; + return *this; +} + +/*--------------------------------------------------------------------------*/ +asub& asub::operator *= ( double x ) +{ *this = *this * x; + return *this; +} + +/*--------------------------------------------------------------------------*/ +asub& asub::operator *= ( const badouble& x ) +{ *this = *this * x; + return *this; +} + +/*--------------------------------------------------------------------------*/ +asub& asub::operator /= ( double x ) +{ *this = *this / x; + return *this; +} + +/*--------------------------------------------------------------------------*/ +asub& asub::operator /= ( const badouble& x ) +{ *this = *this / x; + return *this; +} + +/****************************************************************************/ +/* SUBSCRIPTS (INCREMENT / DECREMENT) */ + +/*--------------------------------------------------------------------------*/ +/* postfix increment */ +adub asub::operator++( int ) +{ locint locat = next_loc(); + + if (trace_flag) + { // old: write_assign_a(locat,location); + put_op(assign_a); + put_locint(location); // = arg + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat]=store[location]; /* location is the local copy of the + asub for which this definition is invoked */ + *this = *this + 1; + return locat ; +} + +/*--------------------------------------------------------------------------*/ +/* postfix decrement */ +adub asub::operator--( int ) +{ locint locat = next_loc(); + + if (trace_flag) + { // old: write_assign_a(locat,location); + put_op(assign_a); + put_locint(location); // = arg + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat]=store[location]; /* location is the local copy of the + asub for which this definition is invoked */ + *this = *this - 1; + return locat ; +} + +/*--------------------------------------------------------------------------*/ +/* prefix increment */ +asub& asub::operator++() +{ *this = *this + 1; + return *this; +} + +/*--------------------------------------------------------------------------*/ +/* prefix decrement */ +asub& asub::operator--() +{ *this = *this - 1; + return *this; +} + +/****************************************************************************/ +/* ALONG STUFF */ + +/*--------------------------------------------------------------------------*/ +along::along() +{ location = next_loc(); +} + +/*--------------------------------------------------------------------------*/ +along& along::operator = ( int coval ) +{ if (trace_flag) + { // old: write_assign_d(location,coval); + if (coval == 0) + { put_op(assign_d_zero); + put_locint(location); // = res + } + else + if (coval == 1.0) + { put_op(assign_d_one); + put_locint(location); // = res + } + else + { put_op(assign_d); + put_locint(location); // = res + put_val(coval); + } + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location]=coval; + return *this; +} + +/*--------------------------------------------------------------------------*/ +along& along::operator = ( const badouble& x ) +{ if (location != x.loc()) + /* test this to avoid for x=x statements adjoint(x)=0 in reverse mode */ + { if (trace_flag) + { // old: write_assign_a(location,x.loc()); + put_op(assign_a); + put_locint(x.loc()); // = arg + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location]=store[x.loc()]; + } + return *this; +} + +/*--------------------------------------------------------------------------*/ +along& along::operator = ( const along& x ) +{ if (location != x.location) + /* test this to avoid for x=x statements adjoint(x)=0 in reverse mode */ + { if (trace_flag) + { // old: write_assign_a(location,x.location); + put_op(assign_a); + put_locint(x.location); // = arg + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location]=store[x.location]; + } + return *this; +} + +/*--------------------------------------------------------------------------*/ +along& along::operator = ( const adub& a ) +{ if (location != a.loc()) + /* test this to avoid for x=x statements adjoint(x)=0 in reverse mode */ + { if (trace_flag) + { // old: write_assign_a(location,a.loc()); + put_op(assign_a); + put_locint(a.loc()); // = arg + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location]=store[a.loc()] ; + } + return *this; +} + +/*--------------------------------------------------------------------------*/ +along::along( int coval ) +{ location = next_loc(); + + if (trace_flag) + { // old: write_int_assign_d(location,coval); + if (coval == 0) + { put_op(assign_d_zero); + put_locint(location); // = res + } + else + if (coval == 1.0) + { put_op(assign_d_one); + put_locint(location); // = res + } + else + { put_op(assign_d); + put_locint(location); // = res + put_val(coval); + } + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location] = coval; +} + +/*--------------------------------------------------------------------------*/ +along::along( const along& a ) +{ location = next_loc(); + + if (trace_flag) + { // old: write_int_assign_a(location,a.location); + put_op(assign_a); + put_locint(a.location); // = arg + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location]=store[a.location]; +} + +/*--------------------------------------------------------------------------*/ +along::along( const adub& a ) +{ location = next_loc(); + + if (trace_flag) + { // old: write_int_assign_a(location,a.loc()); + put_op(assign_a); + put_locint(a.loc()); // = arg + put_locint(location); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location]=store[a.loc()]; +} + +/*--------------------------------------------------------------------------*/ +/* postfix increment */ +adub along::operator++( int ) +{ locint locat = next_loc(); + + if (trace_flag) + { // old: write_assign_a(locat,location); + put_op(assign_a); + put_locint(location); // = arg + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat]=store[location]; + + if (trace_flag) + { // old: write_incr_decr_a(incr_a,location); + put_op(incr_a); + put_locint(location); + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location]++; + return locat ; +} + +/*--------------------------------------------------------------------------*/ +/* postfix decrement */ +adub along::operator--( int ) +{ locint locat = next_loc(); + + if (trace_flag) + { // old: write_assign_a(locat,location); + put_op(assign_a); + put_locint(location); // = arg + put_locint(locat); // = res + + ++vs_ptr; + if (revalso) + write_scaylor(store[locat]); + } + + store[locat]=store[location]; + + if (trace_flag) + { // old: write_incr_decr_a(decr_a,location); + put_op(decr_a); + put_locint(location); + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location]--; + return locat ; +} + +/*--------------------------------------------------------------------------*/ +/* prefix increment */ +along& along::operator++() +{ if (trace_flag) + { // old: write_incr_decr_a(incr_a,location); + put_op(incr_a); + put_locint(location); + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location]++; + return *this; +} + +along& along::operator--() /* prefix decrement */ +{ if (trace_flag) + { // old: write_incr_decr_a(decr_a,location); + put_op(decr_a); + put_locint(location); + + ++vs_ptr; + if (revalso) + write_scaylor(store[location]); + } + + store[location]--; + return *this; +} + + +/****************************************************************************/ +/* THAT'S ALL*/ +#undef _ADOLC_SRC_ +#undef _ADOUBLE_CPP_ + + + + diff --git a/adol-c/SRC/adouble.h b/adol-c/SRC/adouble.h new file mode 100644 index 0000000..1d22af2 --- /dev/null +++ b/adol-c/SRC/adouble.h @@ -0,0 +1,605 @@ +#ifndef _ADOUBLE_H_ +#define _ADOUBLE_H_ +/* + -------------------------------------------------------------- + File adouble.h of ADOL-C version 1.8.6 as of Jan/07/00 + -------------------------------------------------------------- + adouble.h contains the basis for the class of adouble + included here are all the possible functions defined on + the adouble class. Notice that, as opposed to ealier versions, + both the class adub and the class adouble are derived from a base + class (badouble). See below for further explanation. + + Last changes: + 20000107 olvo iostream.h instaed of stream.h + 991210 olvo checking the changes + 991122 olvo new op_codes eq_plus_prod eq_min_prod + for y += x1 * x2 + and y -= x1 * x2 + 981201 olvo last check: + - taputil things changed, includes + 980820 olvo new comparison strategy & some inlines + 980709 olvo modified sign operators + + -------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/* + NOTICE that the purpose of the class adub is merely to avoid the + generation and recording of an extra return adouble for each elementary + operation and function call. The same result can be achieved much + more elegantly with GNUs named return variables, which would also + achieve the desired last in first out pattern for adouble construction + and destruction. +*/ + + +/****************************************************************************/ +/* D I S C L A I M E R + +The ADOL-C Software is provided under the following disclaimer: + +NO WARRANTY. The software was created in the course of a research +endeavor. It is not a commercial package. The present version is +still in development, and is distributed "AS IS, WITH ALL DEFECTS." +By using the software, each user agrees to assume all responsibility +for any and all such use. The authors and Argonne National Laboratory +are not aware that the software or the use thereof infringe any +proprietary right belonging to a third party. However, NO WARRANTY, +CONDITION, OR REPRESENTATION OF ANY KIND, EXPRESS OR IMPLIED, is made +about the software, including without limitation any warranty of title, +noninfringement, merchantability, or fitness for a particular purpose, +by the authors or their affiliated institutions. + +NO CONSEQUENTIAL DAMAGES. Independent of the foregoing disclaimer +of warranties, each person that uses the software thereby agrees, that +NEITHER ARGONNE NATIONAL LABORATORY NOR THE AUTHORS OR THEIR AFFILIATED +INSTITUTIONS SHALL BE LIABLE FOR ANY INCIDENTAL OR CONSEQUENTIAL DAMAGES +IN CONNECTION WITH THE USE OF THE SOFTWARE, INCLUDING WITHOUT LIMITATION +LOST PROFITS OR INJURY TO BUSINESS, WHETHER OR NOT ARGONNE NATIONAL +LABORATORY, AND THE AUTHORS AND THEIR AFFILIATED INSTITUTIONS KNOW OR +HAVE REASON TO KNOW OF THE POSSIBILITY OF SUCH DAMAGES. + +INDEMNITY. Each person that uses the software thereby agrees, to +indemnify and defend Argonne National Laboratory and the authors and +their affiliated institutions, or any of them, against any loss, expense, +claim, damage, or liability of any kind arising from or connected with +their respective uses of the software, and to hold them or any of them +harmless from any of the same, WHETHER OR NOT ARISING IN WHOLE OR IN PART +FROM THE NEGLIGENCE OR GROSS NEGLIGENCE OF ARGONNE NATIONAL LABORATORY OR +ANY OF THE AUTHORS OR THEIR AFFILIATED INSTITUTIONS. + +SUPPORT. Each person that uses this software understands that the software +is not supported by the authors or by their affiliated institutions. +*/ + +/****************************************************************************/ +/* THIS FILE IS C++ */ +#ifdef __cplusplus + + +/****************************************************************************/ +/* INCLUDES */ +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" /* Users Parameters */ + +#include +#include +#include + +/* NOTICE: There are automatic includes at the end of this file! */ + + +/****************************************************************************/ +/* FORWARD DECLARATIONS */ + +/*--------------------------------------------------------------------------*/ +class adouble; +class adub; +class badouble; +class badoublev; +class adoublev; +class adubv; +class along; +/* class doublev; that's history */ + +/*--------------------------------------------------------------------------*/ +void condassign( double &res, const double &cond, + const double &arg1, const double &arg2 ); +void condassign( double &res, const double &cond, + const double &arg ); + +double fmin( const double &x, const double &y ); +double fmax( const double &x, const double &y ); + + +/****************************************************************************/ +/* CLASS BADOUBLE */ + +/* + The class badouble contains the basic definitions for + the arithmetic operations, comparisons, etc. + This is a basic class from which the adub and adouble are + derived. Notice that the constructors/destructors for + the class badouble are of the trivial variety. This is the + main difference among badoubles, adubs, and adoubles. +*/ +class badouble{ + friend class badoublev; + protected: + locint location; + badouble( void ){}; + badouble( const badouble& a ) {location = a.location;}; + badouble( locint lo ) {location = lo;}; + + public: +/*--------------------------------------------------------------------------*/ + inline locint loc( void ) const; /* Helpful stuff */ + inline friend double value( const badouble& ); + + /*------------------------------------------------------------------------*/ + badouble& operator >>= ( double& ); /* Assignments */ + badouble& operator <<= ( double ); + badouble& operator = ( double ); + badouble& operator = ( const badouble& ); + badouble& operator = ( const adub& ); + /* badouble& operator = ( const adouble& ); + !!! olvo 991210: was the same as badouble-assignment */ + +/*--------------------------------------------------------------------------*/ + friend ostream& operator << ( ostream&, const badouble& ); /* IO friends */ + friend istream& operator >> ( istream&, const badouble& ); + + /*------------------------------------------------------------------------*/ + badouble& operator += ( double ); /* Operation + Assignment */ + badouble& operator += ( const badouble& ); + badouble& operator -= ( double y ); + badouble& operator -= ( const badouble& ); + badouble& operator *= ( double ); + badouble& operator *= ( const badouble& ); + badouble& operator /= ( double ); + badouble& operator /= ( const badouble& ); + /* olvo 991122 n2l: new special op_codes */ + badouble& operator += ( const adub& ); + badouble& operator -= ( const adub& ); + +/*--------------------------------------------------------------------------*/ + /* Comparison (friends) */ + inline friend int operator != ( const badouble&, const badouble& ); + inline friend int operator != ( double, const badouble& ); + friend int operator != ( const badouble&, double ); + inline friend int operator == ( const badouble&, const badouble& ); + inline friend int operator == ( double, const badouble& ); + friend int operator == ( const badouble&, double ); + inline friend int operator <= ( const badouble&, const badouble& ); + inline friend int operator <= ( double, const badouble& ); + friend int operator <= ( const badouble&, double ); + inline friend int operator >= ( const badouble&, const badouble& ); + inline friend int operator >= ( double, const badouble& ); + friend int operator >= ( const badouble&, double ); + inline friend int operator > ( const badouble&, const badouble& ); + inline friend int operator > ( double, const badouble& ); + friend int operator > ( const badouble&, double ); + inline friend int operator < ( const badouble&, const badouble& ); + inline friend int operator < ( double, const badouble& ); + friend int operator < ( const badouble&, double ); + + +/*--------------------------------------------------------------------------*/ + /* sign operators (friends) */ + friend adub operator + ( const badouble& x ); + friend adub operator - ( const badouble& x ); + +/*--------------------------------------------------------------------------*/ + /* binary operators (friends) */ + friend adub operator + ( const badouble&, const badouble& ); + friend adub operator + ( double, const badouble& ); + friend adub operator + ( const badouble&, double ); + friend adub operator - ( const badouble&, const badouble& ); + inline friend adub operator - ( const badouble&, double ); + friend adub operator - ( double, const badouble& ); + friend adub operator * ( const badouble&, const badouble& ); + friend adub operator * ( double, const badouble& ); + inline friend adub operator * ( const badouble&, double ); + inline friend adub operator / ( const badouble&, double ); + friend adub operator / ( const badouble&, const badouble& ); + friend adub operator / ( double, const badouble& ); + +/*--------------------------------------------------------------------------*/ + /* unary operators (friends) */ + friend adub exp ( const badouble& ); + friend adub log ( const badouble& ); + friend adub sqrt ( const badouble& ); + friend adub sin ( const badouble& ); + friend adub cos ( const badouble& ); + friend adub tan ( const badouble& ); + friend adub asin ( const badouble& ); + friend adub acos ( const badouble& ); + friend adub atan ( const badouble& ); + +/*--------------------------------------------------------------------------*/ + /* special operators (friends) */ + friend adouble atan2 ( const badouble&, const badouble& ); + /* no internal use of condassign: */ + friend adub pow ( const badouble&, double ); + /* uses condassign internally */ + friend adouble pow ( const badouble&, const badouble& ); + friend adouble pow ( double, const badouble& ); + friend adub log10 ( const badouble& ); + /* User defined version of logarithm to test extend_quad macro */ + friend adouble myquad( const badouble& ); + +/*--------------------------------------------------------------------------*/ + /* Additional ANSI C standard Math functions Added by DWJ on 8/6/90 */ + friend adub sinh ( const badouble& ); + friend adub cosh ( const badouble& ); + friend adub tanh ( const badouble& ); + friend adub asinh ( const badouble& ); + friend adub acosh ( const badouble& ); + friend adub atanh ( const badouble& ); + + friend adub fabs ( const badouble& ); + friend adub ceil ( const badouble& ); + friend adub floor ( const badouble& ); + + friend adub fmax ( const badouble&, const badouble& ); + friend adub fmax ( double, const badouble& ); + friend adub fmax ( const badouble&, double ); + friend adub fmin ( const badouble&, const badouble& ); + friend adub fmin ( double, const badouble& ); + friend adub fmin ( const badouble&, double ); + + friend adub ldexp ( const badouble&, int ); + friend adub frexp ( const badouble&, int* ); + friend adub erf ( const badouble& ); + +/*--------------------------------------------------------------------------*/ + /* Conditionals */ + friend void condassign( adouble &res, const adouble &cond, + const adouble &arg1, const adouble &arg2 ); + friend void condassign( adouble &res, const adouble &cond, + const adouble &arg ); + friend void condassign( along &res, const adouble &cond, + const adouble &arg1, const adouble &arg2 ); + friend void condassign( along &res, const adouble &cond, + const adouble &arg ); +}; + + + +/****************************************************************************/ +/* CLASS ADUB */ + +/* + The class Adub + ---- Basically used as a temporary result. The address for an + adub is usually generated within an operation. That address + is "freed" when the adub goes out of scope (at destruction time). + ---- operates just like a badouble, but it has a destructor defined for it. +*/ + +class adub:public badouble{ + friend class adouble; +/* added Sep/01/96 */ + friend class asub; + friend class along; + protected: + adub( locint lo ):badouble(lo){}; + adub( void ):badouble(0) + { fprintf(DIAG_OUT,"ADOL-C error: illegal default construction of adub" + " variable\n"); + exit(-2); + }; + adub( double ):badouble(0) + { fprintf(DIAG_OUT,"ADOL-C error: illegal construction of adub variable" + " from double\n"); + exit(-2); + }; + + public: + +/*--------------------------------------------------------------------------*/ + /* sign operators (friends) */ + friend adub operator + ( const badouble& x ); + friend adub operator - ( const badouble& x ); + +/*--------------------------------------------------------------------------*/ + /* binary operators (friends) */ + friend adub operator + ( const badouble&, const badouble& ); + friend adub operator + ( double, const badouble& ); + friend adub operator + ( const badouble&, double ); + friend adub operator - ( const badouble&, const badouble& ); + inline friend adub operator - ( const badouble&, double ); + friend adub operator - ( double, const badouble& ); + friend adub operator * ( const badouble&, const badouble& ); + friend adub operator * ( double, const badouble& ); + inline friend adub operator * ( const badouble&, double ); + inline friend adub operator / ( const badouble&, double ); + friend adub operator / ( const badouble&, const badouble& ); + friend adub operator / ( double, const badouble& ); + +/*--------------------------------------------------------------------------*/ + /* unary operators (friends) */ + friend adub exp ( const badouble& ); + friend adub log ( const badouble& ); + friend adub sqrt ( const badouble& ); + friend adub sin ( const badouble& ); + friend adub cos ( const badouble& ); + friend adub tan ( const badouble& ); + friend adub asin ( const badouble& ); + friend adub acos ( const badouble& ); + friend adub atan ( const badouble& ); + +/*--------------------------------------------------------------------------*/ + /* special operators (friends) */ + /* no internal use of condassign: */ + friend adub pow ( const badouble&, double ); + friend adub log10 ( const badouble& ); + +/*--------------------------------------------------------------------------*/ + /* Additional ANSI C standard Math functions Added by DWJ on 8/6/90 */ + friend adub sinh ( const badouble& ); + friend adub cosh ( const badouble& ); + friend adub tanh ( const badouble& ); + friend adub asinh ( const badouble& ); + friend adub acosh ( const badouble& ); + friend adub atanh ( const badouble& ); + + friend adub fabs ( const badouble& ); + friend adub ceil ( const badouble& ); + friend adub floor ( const badouble& ); + + friend adub fmax ( const badouble&, const badouble& ); + friend adub fmax ( double, const badouble& ); + friend adub fmax ( const badouble&, double ); + friend adub fmin ( const badouble&, const badouble& ); + friend adub fmin ( double, const badouble& ); + friend adub fmin ( const badouble&, double ); + + friend adub ldexp ( const badouble&, int ); + friend adub frexp ( const badouble&, int* ); + friend adub erf ( const badouble& ); + +/*--------------------------------------------------------------------------*/ + /* vector operations (friends) */ + friend adub operator*( const badoublev&, double* ); + friend adub operator*( double*, const badoublev& ); + friend adub operator*( const badoublev&, const badoublev& ); + +#ifdef overwrite + ~adub(); +#endif +}; + + +/****************************************************************************/ +/* CLASS ADOUBLE */ +/* + The class adouble. + ---Derived from badouble. Contains the standard constructors/destructors. + ---At construction, it is given a new address, and at destruction, that + address is freed. +*/ +class adouble:public badouble{ + friend class along; + public: + adouble( const adub& ); + adouble( const along& ); + adouble( const adouble& ); + adouble( void ); + adouble( double ); + /* adub prevents postfix operators to occur on the left + side of an assignment which would not work */ + adub operator++( int ); + adub operator--( int ); + badouble& operator++( void ); + badouble& operator--( void ); + +#ifdef overwrite + ~adouble(); +#endif + + adouble& operator = ( double ); + adouble& operator = ( const badouble& ); + /* adouble& operator = ( const adouble& ); + !!! olvo 991210 was the same as badouble-assignment */ + adouble& operator = ( const adub& ); +}; + + +/****************************************************************************/ +/* CLASS ASUB */ +class asub:public badouble +{ locint base, + offset; + public: + asub( locint start, locint index ); +#ifdef overwrite + ~asub(); +#endif + asub& operator <<= ( double ); + asub& operator = ( double ); + /* asub& operator = ( const adub& ); + !!! olvo 991210 is the same as normal assignment */ + asub& operator = ( const badouble& ); + /* added Sep/01/96 */ + /* olvo 991210 seems to be a provisional version */ + asub& operator = ( const asub& ); + asub& operator += ( double ); + asub& operator += ( const badouble& ); + asub& operator -= ( double x ); + asub& operator -= ( const badouble& ); + asub& operator *= ( double x ); + asub& operator *= ( const badouble& ); + asub& operator /= ( double x ); + asub& operator /= ( const badouble& ); + /* adub prevents postfix operators to occur on the left + side of an assignment which would not work */ + adub operator++( int ); + adub operator--( int ); + asub& operator++( void ); + asub& operator--( void ); +}; + + +/****************************************************************************/ +/* CLASS ALONG */ +/* The class along was originally designed for the sole purpose of + allowing subscripting operations with computable ON THE TAPE. + The current definition refers to badouble, i.e. it is a + floating point class. The current constuction allows to + use alongs in the same way as adoubles. Especially adubs can + can be used as subscripts, i.e. the results of "active computations". + This useful because people want to compute the indices on the tape. + Notice, that along does NOT perform integer arithmetic. + This is the major disadvantage of the current along. */ +class along:public badouble +{ friend class adouble; + public: + along( const adub& ); + along( const along& ); + along( void ); + along( int ); +#ifdef overwrite + ~along(); +#endif + along& operator = ( int ); + /* along& operator = ( const adouble& ); + !!! olvo 991210 is the same as badouble-assignment */ + along& operator = ( const badouble& ); + along& operator = ( const along& ); + along& operator = ( const adub& ); + /* adub prevents postfix operators to occur on the left + side of an assignment which would not work */ + adub operator++( int ); + adub operator--( int ); + along& operator++( void ); + along& operator--( void ); +}; + + +/****************************************************************************/ +/* INLINE DEFINITIONS */ + +/*--------------------------------------------------------------------------*/ +inline locint badouble::loc( void ) const +{ return location; +} + +/*--------------------------------------------------------------------------*/ +inline double value(const badouble& x) +{ extern double* store; + return store[x.location]; +} + +/*--------------------------------------------------------------------------*/ + /* Comparison */ +inline int operator != ( const badouble& u, const badouble& v ) +{ return (u-v != 0); +} + +inline int operator != ( double coval, const badouble& v) +{ if (coval) + return (-coval+v != 0); + else + return (v != 0); +} + +inline int operator == ( const badouble& u, const badouble& v ) +{ return (u-v == 0); +} + +inline int operator == ( double coval, const badouble& v) +{ if (coval) + return (-coval+v == 0); + else + return (v == 0); +} + +inline int operator <= ( const badouble& u, const badouble& v ) +{ return (u-v <= 0); +} + +inline int operator <= ( double coval, const badouble& v ) +{ if (coval) + return (-coval+v >= 0); + else + return (v >= 0); +} + +inline int operator >= ( const badouble& u, const badouble& v ) +{ return (u-v >= 0); +} + +inline int operator >= ( double coval, const badouble& v ) +{ if (coval) + return (-coval+v <= 0); + else + return (v <= 0); +} + +inline int operator > ( const badouble& u, const badouble& v ) +{ return (u-v > 0); +} + +inline int operator > ( double coval, const badouble& v ) +{ if (coval) + return (-coval+v < 0); + else + return (v < 0); +} + +inline int operator < ( const badouble& u, const badouble& v ) +{ return (u-v < 0); +} + +inline int operator < ( double coval, const badouble& v ) +{ if (coval) + return (-coval+v > 0); + else + return (v > 0); +} + +/*--------------------------------------------------------------------------*/ +/* Subtract a floating point from an adouble */ +inline adub operator - ( const badouble& x , double coval ) +{ return (-coval) + x; +} + +/*--------------------------------------------------------------------------*/ +/* Multiply an adouble by a floating point */ +inline adub operator * (const badouble& x, double coval) +{ return coval * x; +} + +/*--------------------------------------------------------------------------*/ +/* Divide an adouble by a floating point */ +inline adub operator / (const badouble& x, double coval) +{ return (1.0/coval) * x; +} + + +/****************************************************************************/ +/* STOCK OPERATIONS */ +void take_stock (void); +locint keep_stock (void); + + +/****************************************************************************/ +/* AUTOMTIC INCLUDES */ +#include "avector.h" /* active vector classes */ +#include "taputil.h" /* trace on/off */ + + +/****************************************************************************/ +/* THAT'S ALL*/ +#endif +#endif + + + + + + diff --git a/adol-c/SRC/adutils.h b/adol-c/SRC/adutils.h new file mode 100644 index 0000000..7fa018e --- /dev/null +++ b/adol-c/SRC/adutils.h @@ -0,0 +1,30 @@ +#ifndef _ADUTILS_H_ +#define _ADUTILS_H_ +/* + ------------------------------------------------------------- + File adutils.h of ADOL-C version 1.8.0 as of Nov/30/98 + ------------------------------------------------------------- + Provides all C/C++ interfaces of ADOL-C. + NOTICE: This file is kept for compatibility reasons only. + The new header adolc.h is included. + + Last changes: + 981130 olvo this remaining version + + ------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/* INCLUDES */ + +#include "adolc.h" + + +/****************************************************************************/ +/* THAT'S ALL */ + +#endif + + + diff --git a/adol-c/SRC/adutilsc.h b/adol-c/SRC/adutilsc.h new file mode 100644 index 0000000..1d00e30 --- /dev/null +++ b/adol-c/SRC/adutilsc.h @@ -0,0 +1,35 @@ +#ifndef _ADUTILSC_H_ +#define _ADUTILSC_H_ +/* + ------------------------------------------------------------- + File adutilsc.h of ADOL-C version 1.8.0 as of Nov/30/98 + ------------------------------------------------------------- + Provides all C interfaces of ADOL-C. + NOTICE: This file is kept for compatibility reasons only. + The new header adolc.h is included. + + Last changes: + 981130 olvo this remaining version + + ------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/* INCLUDES */ + +#include "adolc.h" + + +/****************************************************************************/ +/* THAT'S ALL */ + +#endif + + + + + + + + diff --git a/adol-c/SRC/avector.C b/adol-c/SRC/avector.C new file mode 100644 index 0000000..366d9fd --- /dev/null +++ b/adol-c/SRC/avector.C @@ -0,0 +1,1109 @@ +#define _ADOLC_SRC_ +#define _AVECTOR_CPP_ +/* + ---------------------------------------------------------------- + File avector.C of ADOL-C version 1.8.0 as of Nov/30/98 + ---------------------------------------------------------------- + Avector.C contains the necessary routines for vector operations + that are defined in avector.h. Note: avector.h is included + automatically by adouble.h, and hence does not need to be + included here again. + + Last changes: + 981130 olvo: last check (includes ...) + NOTICE: I think everything concerning vectors + has to be checked again in detail! + 980930 olvo allow overwrites in av*=a, av*a, a*av + 980924 olvo changed all int_* opcodes + 980721 olvo write of taylors in m_subscript + 980714 olvo: debugging vector - matrix stuff + 980713 olvo: elimination of "writes" from taputil1.c completed + 980707 olvo: (1) used void write_dot_av_av(..) + (2) taping with keep + + ---------------------------------------------------------------- +*/ + +/****************************************************************************/ +/* INCLUDES */ +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" /* Users Parameters */ +#include "adouble.h" +#include "oplate.h" +#include "taputil.h" +#include "tayutil.h" + +#include +#include + + +/****************************************************************************/ +/* GLOBAL VARS & ROUTINES */ + +/*--------------------------------------------------------------------------*/ +extern double* store; +extern int trace_flag; + +/*--------------------------------------------------------------------------*/ +extern locint next_loc(int size); +extern locint next_loc(); +extern locint free_loc(int,int); + + +/****************************************************************************/ +/* VECTOR CONSTRUCTORS */ + +/*--------------------------------------------------------------------------*/ +adoublev::adoublev( int n ) +{ +#ifdef DEBUG + fprintf(DIAG_OUT,"ADOL-C debug:Declaring active vector\n"); +#endif + size = n; + start_loc = next_loc(size); +} + +/*--------------------------------------------------------------------------*/ +adoublev::adoublev( const adoublev &arg ) +{ +#ifdef DEBUG + fprintf(DIAG_OUT,"ADOL-C debug:Declaring active vector and" + " initializing from adoublev\n"); +#endif + size = arg.size; + start_loc = next_loc(size); + + if (trace_flag) + { // old: write_intvec_assign_av(size,start_loc,arg.start_loc); + put_op(assign_av); + put_locint(arg.start_loc); // = arg + put_locint(size); + put_locint(start_loc); // = res + + vs_ptr += size; + if (revalso) + write_scaylors((store+start_loc),size); + } + + for (int i=0; i 0) + { put_op(assign_dv); + put_locint(vals_left); + put_locint(loc); + put_vals_r(d,vals_left); + } + + vs_ptr += size; + if (revalso) + write_scaylors((store+start_loc),size); + } + + for (int i=0; i 0) + { put_op(assign_dv); + put_locint(vals_left); + put_locint(loc); + put_vals_r(d,vals_left); + } + } + + return *this; +} + +/*--------------------------------------------------------------------------*/ +adoublev& adoublev::operator = ( const badoublev& x ) +{ if(start_loc != x.loc()) + /* test this to avoid adjoint(x)=0 for x=x in reverse */ + { if (trace_flag) + { // old: write_assign_av(size,start_loc,x.loc()); + put_op(assign_av); + put_locint(x.loc()); // = arg + put_locint(size); + put_locint(start_loc); // = res + + vs_ptr += size; + if (revalso) + write_scaylors((store+start_loc),size); + } + + for (int i=0; i=size) + { fprintf (DIAG_OUT,"ADOL-C error: adoublev index out of range.\n"); + exit(-3); + } + + return start_loc+i; +} + + +/****************************************************************************/ +/* ASSIGNMENTS */ + +/*--------------------------------------------------------------------------*/ +badoublev& badoublev::operator = ( const badoublev &arg ) +{ +#ifdef DEBUG + fprintf(DIAG_OUT,"ADOL-C debug:In badoublev = badoublev\n"); +#endif + if (start_loc != arg.start_loc) + /* test this to avoid adjoint(x)=0 for x=x in reverse */ + { if (trace_flag) + { // old: write_assign_av(size,start_loc,arg.start_loc); + put_op(assign_av); + put_locint(arg.start_loc); // = arg + put_locint(size); + put_locint(start_loc); // = res + + vs_ptr += size; + if (revalso) + write_scaylors((store+start_loc),size); + } + + for (int i=0; i>= ( double* coval ) +{ +#ifdef DEBUG + fprintf(DIAG_OUT,"ADOL-C debug:DEP EQ double* operator\n"); +#endif + if (trace_flag) + { // old: write_assign_depvec(size,start_loc); + dep_ptr += size; + put_op(assign_depvec); + put_locint(size); + put_locint(start_loc); // = res + } + + for (int i=0; i=m) + { fprintf (DIAG_OUT,"ADOL-C error: adoublem index out of range.\n"); + exit(-3); + } + return index[i]; +} + +/*--------------------------------------------------------------------------*/ +asub badoublev::operator[]( const along &i ) const +{ int j=(int)(store[i.loc()]); +#ifdef DEBUG + fprintf(DIAG_OUT,"ADOL-C debug:In along overloaded []\n"); +#endif + /* Used so can access the vector like an array with the [] */ + /* Check if out of range */ + if ((j<0) || (j>=size)) + fprintf (DIAG_OUT,"ADOL-C warning:: adoublev index out of range.\n"); + return asub(start_loc,i.loc()); +} + +/****************************************************************************/ +/* ASUBV OPERATIONS */ + +#ifdef overwrite +/*--------------------------------------------------------------------------*/ +asubv::~asubv() +{ +#ifdef DEBUG + fprintf(DIAG_OUT,"ADOL-C debug:Destructing active subscript vector\n"); +#endif + free_loc(start_loc,size); +} + +#endif + +/*--------------------------------------------------------------------------*/ +asubv::asubv( adoublev* start, locint index ) +{ +#ifdef DEBUG + fprintf(DIAG_OUT,"ADOL-C debug: Constructing an asubv with 3 arguments\n"); +#endif + begin = (start[0]).loc(); /* start of matrix */ + base = (start[(int)store[index]]).loc(); /* start of the i-th row */ + offset = index; + size = (start[(int)store[index]]).sz(); /* size of the row-vector */ + start_loc = next_loc(size); + + if (trace_flag) + { // old: write_associating_vector(m_subscript,start_loc,begin,offset,size); + put_op(m_subscript); + put_locint(begin); + put_locint(offset); + put_locint(size); + put_locint(start_loc); + put_val(store[offset]); + + /* olvo 980721 new n3l */ + vs_ptr += size; + if (revalso) + write_scaylors(store+start_loc,size); + } + + for(int i=0;i=n) + fprintf (DIAG_OUT,"ADOL-C warning:: adoublem index out of range.\n"); + return asubv(index,i.loc()); +} + +/*--------------------------------------------------------------------------*/ +asubv& asubv::operator = ( const adubv& a ) +{ if (trace_flag) + { // old: write_associating_vector(m_subscript_l,a.loc(),begin,offset,size); + put_op(m_subscript_l); + put_locint(begin); + put_locint(offset); + put_locint(size); + put_locint(a.loc()); + put_val(store[offset]); + + vs_ptr+=size; + if (revalso) + write_scaylors((store+(begin+(int)store[offset])),size); + } + + for(int i=0;i 0) + { put_op(m_subscript_ld); + put_locint(begin); + put_locint(offset); + put_val(store[offset]); + put_locint(loc); + put_locint(vals_left); + put_vals_r(d,vals_left); + } + + vs_ptr += size; + if (revalso) + write_scaylors((store+(begin+(int)store[offset])),size); + } + + for(int i=0;i class of basic active vectors. + adubv --> class of temporary active vectors. + (derived from badoublev. Contains copy constructors, + destructors.) + adoublev --> class of active vectors. (derived from badoublev, + contains the standard constructors and destructors. + + Last changes: + 981130 olvo: last check (includes ...) + NOTICE: I think everything concerning vectors + has to be checked again in detail! + + -------------------------------------------------------------- +*/ + +/****************************************************************************/ +/* THIS FILE IS C++ */ +#ifdef __cplusplus + + +/****************************************************************************/ +/* INCLUDES */ +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" /* Users Parameters */ + +/****************************************************************************/ +/* FORWARD DECLARATIONS */ +class badoublev; +class adoublev; +class adubv; +/* class doublev; removed 1/95 */ +class err_retu; +class asubv; + + +/****************************************************************************/ +/* ANY ERROR CLASS */ +class err_retu +{ char* message; + public: + err_retu(char* x){printf("%s \n",x);}; +}; + + +/****************************************************************************/ +/* DECLARATION OF VECTOR CLASSES */ + +/* Passive vectors and matrices were REMOVED 1/95 */ + + +/****************************************************************************/ +/* CLASS BADOUBLEV */ +class badoublev +{ + protected: + locint start_loc; /* Starting location of vector in store */ + int size; /* Size of the vector */ + badoublev(){}; + badoublev(int lo, int sz){start_loc = lo; size=sz;}; + badoublev(const badoublev& a){start_loc = a.start_loc; size=a.size;}; + + public: + + /* Access functions */ + int sz() const {return size;} /* Get the size of the vector */ + int loc() const {return start_loc;} /* Get the size of the vector */ + + asub operator[](const along&) const; + +/* excluded before 1/95 + badoublev& operator >>= (doublev& ); + badoublev& operator <<= (doublev& ); + badoublev& operator >>= (double* ); + badoublev& operator <<= (double* ); +*/ + + badouble operator[](int) const; /* Can access component like an array */ + + badoublev& operator+=(const badoublev&); + badoublev& operator-=(const badoublev&); + badoublev& operator*=(double); + badoublev& operator/=(double); +/* removed 1/95 + badoublev& operator-=(const doublev&); + badoublev& operator+=(const doublev&); +*/ +/* removed Sep/01/96 + badoublev& operator-=(double*); + badoublev& operator+=(double*); +*/ + badoublev& operator*=(const badouble& ); + badoublev& operator/=(const badouble& ); + friend adubv operator/(const badoublev &op1, const badouble &n); + inline friend adubv operator/(const badoublev &op1, double n); +/* removed 1/95 + badoublev& operator= (const doublev&); +*/ + badoublev& operator= (const badoublev&); + badoublev& operator= (const adubv &y); + badoublev& operator= (const adoublev &y); + + friend ostream& operator << (ostream&, const badoublev&); + + friend adubv operator+ (const badoublev &x); + friend adubv operator- (const badoublev &x); + + /* overload operations */ + friend adubv operator+(const badoublev &op1,const badoublev &op2); + friend adubv operator-(const badoublev &op1,const badoublev &op2); + friend adubv operator*(const badoublev &op1, double n); + friend adubv operator*(double n, const badoublev &op1); + friend adub operator*(const badoublev &op1, const badoublev &op2); + + /* overloaded for interaction of constant and active vectors */ +/* removed 1/95 + friend adubv operator+(const badoublev &op1, const doublev &op2); + friend adubv operator+(const doublev &op1, const badoublev &op2); +*/ + friend adubv operator+(const badoublev &op1, double* op2); + friend adubv operator+(double* op2, const badoublev &op1); +/* removed 1/95 + friend adubv operator-(const badoublev &op1, const doublev &op2); + friend adubv operator-(const doublev &op1, const badoublev &op2); +*/ + friend adubv operator-(const badoublev &op1, double* op2); + friend adubv operator-(double* op1, const badoublev &op2); +/* removed 1/95 + friend adub operator*(const badoublev &op1, const doublev &op2); + friend adub operator*(const doublev &op1, const badoublev &op2); +*/ + friend adub operator*(const badoublev &op1, double* op2); + friend adub operator*(double* op1, const badoublev &op2); + + /* overloaded for interaction of active scalars and active vectors */ +/* removed 1/95 + friend adubv operator/(const doublev &op1, const badouble &n); +*/ + friend adubv operator*(const badoublev &op1, const badouble &n); + friend adubv operator*(const badouble &n, const badoublev &op1); + /* excluded operations */ + err_retu operator>>=(double op1) {double x=op1; return("ADOL-C error: illegal argument combination for operator >>=\n"); }; + err_retu operator<<=(double op1) {double x=op1; return("ADOL-C error: illegal argument combination for operator <<=\n"); }; + err_retu operator+= (double op1) {double x=op1; return("ADOL-C error: illegal argument combination for operator +=\n"); }; + err_retu operator-= (double op1) {double x=op1; return("ADOL-C error: illegal argument combination for operator -=\n"); }; + inline friend err_retu operator+(const badoublev &op1,double op2) {badoublev y=op1; double x=op2; return("ADOL-C error: illegal argument combination for operator +\n"); }; + inline friend err_retu operator-(const badoublev &op1,double op2) {badoublev y=op1; double x=op2; return("ADOL-C error: illegal argument combination for operator -\n"); }; + inline friend err_retu operator+(double op1,const badoublev &op2) {badoublev y=op2; double x=op1; return("ADOL-C error: illegal argument combination for operator +\n"); }; + inline friend err_retu operator-(double op1,const badoublev &op2) {badoublev y=op2; double x=op1; return("ADOL-C error: illegal argument combination for operator -\n"); }; +}; + + +/****************************************************************************/ +/* CLASS ADUBV */ +class adubv:public badoublev{ + adubv(int lo,int sz){start_loc=lo;size=sz;}; +/* removed 1/95 + adubv(doublev&); +*/ + adubv():badoublev(0,0){ + cout << "ADOL-C error: illegal default construction of adub variable\n" ; + exit(-2); + }; + + public: +/* removed 1/95 + friend adub operator*(const badoublev &op1, const doublev &op2); + friend adub operator*(const doublev &op1, const badoublev &op2); +*/ + friend adub operator*(const badoublev &op1, double* op2); + friend adub operator*(double* op1, const badoublev &op2); + friend adub operator*(const badoublev &op1, const badoublev &op2); + /* excluded because g++ warnings + friend adub operator*(const badoublev &op1, const doublev &op2); + friend adub operator*(const doublev &op1, const badoublev &op2); + */ +/* removed 1/95 + friend adubv operator+(const badoublev &op1, const doublev &op2); + friend adubv operator+(const doublev &op1, const badoublev &op2); + friend adubv operator-(const badoublev &op1, const doublev &op2); + friend adubv operator-(const doublev &op1, const badoublev &op2); + friend adubv operator/(const doublev &op1, const badouble &n); + friend adubv operator*(const doublev &op1, const badouble &n); + friend adubv operator*(const badouble &n, const doublev &op1); +*/ + friend adubv operator/(const badoublev &op1, const badouble &n); + inline friend adubv operator/(const badoublev &op1, double n); + friend adubv operator+ (const badoublev &x); + friend adubv operator- (const badoublev &x); + friend adubv operator+(const badoublev &op1,const badoublev &op2); + friend adubv operator-(const badoublev &op1,const badoublev &op2); + friend adubv operator*(const badoublev &op1, double n); + friend adubv operator*(double n, const badoublev &op1); + /* excluded because g++ warnings + friend adubv operator+(const badoublev &op1, const doublev &op2); + friend adubv operator+(const doublev &op1, const badoublev &op2); + */ + friend adubv operator+(const badoublev &op1, double* op2); + friend adubv operator+(double* op2, const badoublev &op1); + /* excluded because g++ warnings + friend adubv operator-(const badoublev &op1, const doublev &op2); + friend adubv operator-(const doublev &op1, const badoublev &op2); + */ + friend adubv operator-(const badoublev &op1, double* op2); + friend adubv operator-(double* op1, const badoublev &op2); + /* excluded because g++ warnings + friend adubv operator/(const doublev &op1, const badouble &n); + */ + friend adubv operator*(const badoublev &op1, const badouble &n); + friend adubv operator*(const badouble &n, const badoublev &op1); +#ifdef overwrite + ~adubv(); +#endif +}; + + +/****************************************************************************/ +/* CLASS ADOUBLEV */ +class adoublev:public badoublev +{ + friend class adoublem; + adoublev(){}; + public: + adoublev(const adubv& a); + adoublev(const adoublev&); + adoublev(int sz); +// adoublev(int n, double *values); +/* removed 1/95 + adoublev(doublev&); +*/ +#ifdef overwrite + ~adoublev(); +#endif +/* removed 1/95 + adoublev& operator= (const doublev &y); +*/ + adoublev& operator= (const badoublev&); + adoublev& operator= (const adoublev&); + adoublev& operator= (const adubv&); + adoublev& operator= (double y); + adoublev& operator= (double* y); +/* removed 1/95 + adoublev& operator >>= (doublev& ); + adoublev& operator <<= (doublev& ); +*/ + adoublev& operator >>= (double* ); + adoublev& operator <<= (double* ); +}; + +/*--------------------------------------------------------------------------*/ +inline adubv operator / (const badoublev& x, double y){return (1.0/y)*x;} + + +/****************************************************************************/ +/* CLASS ADOUBLEM */ +class adoublem +{ + int n, m; /* Size of the matrix */ + adoublev *index; /* So each row is an adoublev */ + public: + adoublem(int n, int m); + adoublem(const adoublem& ); + ~adoublem(); + adoublev& operator[](int i); /* Can access component like an array */ + asubv operator[](const along&); +}; + + +/****************************************************************************/ +/* CLASS ASUBV */ +class asubv:public badoublev +{ + locint base,offset,begin; + public: + asubv(adoublev* start, locint index); +#ifdef overwrite + ~asubv(); +#endif +/* removed 1/95 + asubv& operator <<= (doublev&); + asubv& operator = (doublev); +*/ + asubv& operator <<= (double*); + asubv& operator = (double*); + asubv& operator = (const adubv&); + asubv& operator = (const badoublev&); +/* added Sep/01/96 */ + asubv& operator = (const asubv&); + asubv& operator += (const badoublev&); + asubv& operator -= (const badoublev&); +/* there are currently no +=, -= operators for double* + right hand sides. They woudl require a special treatment + similar to the assignment operators caused by the buffered + writing of the constant right hand side to the tape. */ + asubv& operator *= (double x); + asubv& operator *= (const badouble&); + asubv& operator /= (double x); + asubv& operator /= (const badouble&); +}; + + +/****************************************************************************/ +/* THAT'S ALL*/ +#endif +#endif + diff --git a/adol-c/SRC/convolut.c b/adol-c/SRC/convolut.c new file mode 100644 index 0000000..a3d67a7 --- /dev/null +++ b/adol-c/SRC/convolut.c @@ -0,0 +1,173 @@ +#define _CONVOLUT_C_ +#define _ADOLC_SRC_ +/* + ---------------------------------------------------------------- + File convolut.c of ADOL-C version 1.8.0 as of Nov/30/98 + ---------------------------------------------------------------- + Contains convolution routines used in ho_reverse.c (definition) + + Last changed : + 981130 olvo last check + 980707 olvo changed index range + 980616 olvo (1) void copyAndZeroset(..) + void inconv0(..) + void deconv0(..) + (2) code optimization + + ---------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/* INCLUDES */ +#include "dvlparms.h" +#include "usrparms.h" +#include "convolut.h" + +#ifdef __cplusplus +extern "C" { +#endif + + +/****************************************************************************/ +/* CONVOLUTION */ + +/*--------------------------------------------------------------------------*/ +/* Evaluates convolution of a and b to c */ +void conv( int dim, double *a, revreal *b, double *c ) +{ double tmpVal; + int i,j; + for (i=dim-1; i>=0; i--) + { tmpVal = a[i]*b[0]; + for (j=1; j<=i; j++) + tmpVal += a[i-j]*b[j]; + c[i] = tmpVal; + } +} + + +/****************************************************************************/ +/* INCREMENTAL CONVOLUTION */ + +/*--------------------------------------------------------------------------*/ +/* Increments truncated convolution of a and b to c */ +void inconv( int dim, double *a, revreal *b, double *c ) +{ double tmpVal; + int i,j; + for (i=dim-1; i>=0; i--) + { tmpVal = a[i]*b[0]; + for (j=1; j<=i; j++) + tmpVal += a[i-j]*b[j]; + c[i] += tmpVal; + } +} + +/*--------------------------------------------------------------------------*/ +/* olvo 980616 nf */ +/* Increments truncated convolution of a and b to c and sets a to zero */ +void inconv0( int dim, double *a, revreal *b, double *c ) +{ double tmpVal; + int i,j; + for (i=dim-1; i>=0; i--) + { tmpVal = a[i]*b[0]; + a[i] = 0; + for (j=1; j<=i; j++) + tmpVal += a[i-j]*b[j]; + c[i] += tmpVal; + } +} + + +/****************************************************************************/ +/* DECREMENTAL CONVOLUTION */ + +/*--------------------------------------------------------------------------*/ +/* Decrements truncated convolution of a and b to c */ +void deconv( int dim, double *a, double *b, double *c ) +{ double tmpVal; + int i,j; + for (i=dim-1; i>=0; i--) + { tmpVal = a[i]*b[0]; + for (j=1; j<=i; j++) + tmpVal += a[i-j]*b[j]; + c[i] -= tmpVal; + } +} + +/*--------------------------------------------------------------------------*/ +/* olvo 980616 nf */ +/* Decrements truncated convolution of a and b to c and sets a to zero */ +void deconv0( int dim, double *a, revreal *b, double *c ) +{ double tmpVal; + int i,j; + for (i=dim-1; i>=0; i--) + { tmpVal = a[i]*b[0]; + a[i] = 0; + for (j=1; j<=i; j++) + tmpVal += a[i-j]*b[j]; + c[i] -= tmpVal; + } +} + + +/****************************************************************************/ +/* OTHER USEFUL ROUTINES */ + +/*--------------------------------------------------------------------------*/ +void divide( int dim, revreal *a, revreal *b, revreal *c ) +{ int i,j; + double rec = 1/b[0]; + for (i=0; i=0; i--) + { a+=i; + tmp = (*a) * (*b); + for (j=1; j<=i; j++) + tmp += (*(--a))*(*(++b)); + b-=i; + (*(--c)) = tmp; + } + +} + + +/****************************************************************************/ +/* INCREMENTAL CONVOLUTION */ + +/*--------------------------------------------------------------------------*/ +/* Increments truncated convolution of a and b to c */ +void inconv( int dim, double *a, revreal *b, double *c ) +{ int i,j; + double tmp; + c+=dim; + for (i=dim-1; i>=0; i--) + { a+=i; + tmp = (*a) * (*b); + for (j=1; j<=i; j++) + tmp += (*(--a))*(*(++b)); + b-=i; + (*(--c)) += tmp; + } +} + +/*--------------------------------------------------------------------------*/ +/* olvo 980616 nf */ +/* Increments truncated convolution of a and b to c and sets a to zero */ +void inconv0( int dim, double *a, revreal *b, double *c ) +{ int i,j; + double tmp; + c+=dim; + for (i=dim-1; i>=0; i--) + { a+=i; + tmp = (*a) * (*b); + (*a) = 0.0; + for (j=1; j<=i; j++) + tmp += (*(--a))*(*(++b)); + b-=i; + (*(--c)) += tmp; + } +} + + +/****************************************************************************/ +/* DECREMENTAL CONVOLUTION */ + +/*--------------------------------------------------------------------------*/ +/* Decrements truncated convolution of a and b to c */ +void deconv( int dim, double *a, double *b, double *c ) +{ int i,j; + double tmp; + c+=dim; + for (i=dim-1; i>=0; i--) + { a+=i; + tmp = (*a) * (*b); + for (j=1; j<=i; j++) + tmp += (*(--a))*(*(++b)); + b-=i; + (*(--c)) -= tmp; + } +} + +/*--------------------------------------------------------------------------*/ +/* olvo 980616 nf */ +/* Decrements truncated convolution of a and b to c and sets a to zero */ +void deconv0( int dim, double *a, revreal *b, double *c ) +{ int i,j; + double tmp; + c+=dim; + for (i=dim-1; i>=0; i--) + { a+=i; + tmp = (*a) * (*b); + (*a) = 0.0; + for (j=1; j<=i; j++) + tmp += (*(--a))*(*(++b)); + b-=i; + (*(--c)) -= tmp; + } +} + + +/****************************************************************************/ +/* OTHER USEFUL ROUTINES */ + +/*--------------------------------------------------------------------------*/ +void divide( int dim, revreal *a, revreal *b, revreal *c ) +{ int i,j; + double rec = 1/b[0]; + for (i=0; i + + +/****************************************************************************/ +/* Possible ADOL-C options. */ +#define overwrite overwrite + + +/****************************************************************************/ +/* ADOLC - Version. */ +#define ADOLC_VERSION 1 +#define ADOLC_SUBVERSION 8 +#define ADOLC_PATCHLEVEL 5 + + +#endif + + + + + + + + diff --git a/adol-c/SRC/fo_rev.c b/adol-c/SRC/fo_rev.c new file mode 100644 index 0000000..c818e7d --- /dev/null +++ b/adol-c/SRC/fo_rev.c @@ -0,0 +1,2016 @@ +#define _FO_REV_C_ +#define _ADOLC_SRC_ +/* + ----------------------------------------------------------------- + File fo_rev.c of ADOL-C version 1.8.5 as of Nov/22/99 + ----------------------------------------------------------------- + Contains the routines : + fos_reverse (first-order-scalar reverse mode) : define _FOS_ + fov_reverse (first-order-vector reverse mode) : define _FOV_ + + Uses the preprocessor to compile the 2 different object files + + Last changed : + 991122 olvo new op_codes eq_plus_prod eq_min_prod + for y += x1 * x2 + and y -= x1 * x2 + 981130 olvo last check (includes ...) + 980929 olvo allow reflexive operations for + - vector operations: eq_mult_av_a, + mult_a_av, div_av_a + 980924 olvo (1) Lots of small changes (Atemp, At --> Aqo) + (2) new macros AQO* + (3) deleted all int_* opcodes + (4) allow reflexive operations for + - cond_assign, cond_assign_s + (changed code completely) + 980922 olvo (1) allow reflexive operations for + - div_d_a, div_a_a + 980921 olvo (1) changed save-order in sin/cos + (2) allow reflexive operations for + - pow + 980820 olvo new comparison strategy + 980721 olvo write of taylors in subscript and + subscript_m + 980714 olvo some error elimination + op-code mult_av_a removed + 980713 olvo debugging and optimizing + 980710 olvo sin/cos writes 2 taylors + 980709 olvo new operation code: neg_sign_a + pos_sign_a + 980706 olvo new operation code: int_adb_d_one + int_adb_d_zero + 980703 olvo new operation code: assign_d_one + assign_d_zero + 980626 olvo vector operations & subscripts + 980623 mitev/olvo revision + stock stuff + 980616 olvo griewank's idea II + 980615 olvo griewank's idea + 980612 mitev + + ----------------------------------------------------------------- +*/ + +/* + ----------------------------------------------------------------- + There are four basic versions of the procedure `reverse', which + are optimized for the cases of scalar or vector reverse sweeps + with first or higher derivatives, respectively. In the calling + sequence this distinction is apparent from the type of the + parameters `lagrange' and `results'. The former may be left out + and the integer parameters `depen', `indep', `degre', and `nrows' + must be set or default according to the following matrix of + calling cases. + + no lagrange double* lagrange double** lagrange + +double* gradient of scalar weight vector times infeasible +results valued function Jacobian product combination + + ( depen = 1 , ( depen > 0 , + degre = 0 , degre = 0 , ------ + nrows = 1 ) nrows = 1 ) + +double** Jacobian of vector weight vector times weight matrix +results valued function Taylor-Jacobians times Jacobian + + ( 0 < depen ( depen > 0 , ( depen > 0 , + = nrows , degre > 0 , degre = 0 , + degre = 0 ) nrows = 1 ) nrows > 0 ) + +double*** full family of ------------ weigth matrix x +results Taylor-Jacobians ------------ Taylor Jacobians + ----------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/* MACROS */ +#undef _ADOLC_VECTOR_ +#undef _HI_ORDER_ + +/*--------------------------------------------------------------------------*/ +#ifdef _FOS_ +#define GENERATED_FILENAME "fos_reverse" + +#define RESULTS(l,indexi) results[indexi] +#define LAGRANGE(l,indexd) lagrange[indexd] + +/*--------------------------------------------------------------------------*/ +#elif _FOV_ +#define GENERATED_FILENAME "fov_reverse" + +#define _ADOLC_VECTOR_ + +#define RESULTS(l,indexi) results[l][indexi] +#define LAGRANGE(l,indexd) lagrange[l][indexd] + +#else +#error Error ! Define [_FOS_ | _FOV_] +#endif + +/*--------------------------------------------------------------------------*/ +/* access to variables */ + +#ifdef _FOS_ +#define ARES *Ares +#define AARG *Aarg +#define AARG1 *Aarg1 +#define AARG2 *Aarg2 +#define AQO *Aqo + +#define ARES_INC *Ares +#define AARG_INC *Aarg +#define AARG1_INC *Aarg1 +#define AARG2_INC *Aarg2 +#define AQO_INC *Aqo + +#define ARES_INC_O Ares +#define AARG_INC_O Aarg +#define AARG1_INC_O Aarg1 +#define AARG2_INC_O Aarg2 +#define AQO_INC_O Aqo + +#define ASSIGN_A(a,b) a = &b; + +#else /* _FOV_, _HOS_, _HOV_ */ +#define ARES *Ares +#define AARG *Aarg +#define AARG1 *Aarg1 +#define AARG2 *Aarg2 +#define AQO *Aqo + +#define ARES_INC *Ares++ +#define AARG_INC *Aarg++ +#define AARG1_INC *Aarg1++ +#define AARG2_INC *Aarg2++ +#define AQO_INC *Aqo++ + +#define ARES_INC_O Ares++ +#define AARG_INC_O Aarg++ +#define AARG1_INC_O Aarg1++ +#define AARG2_INC_O Aarg2++ +#define AQO_INC_O Aqo++ + +#define ASSIGN_A(a,b) a = b; +#endif + +#ifdef _HI_ORDER_ + +#define TRES *Tres +#define TARG *Targ +#define TARG1 *Targ1 +#define TARG2 *Targ2 + +#define ASSIGN_T(a,b) a = b; +#else + +#define TRES T[res] +#define TARG T[arg] +#define TARG1 T[arg1] +#define TARG2 T[arg2] + +#define ASSIGN_T(a,b) +#endif + +/*--------------------------------------------------------------------------*/ +/* loop stuff */ +#ifdef _ADOLC_VECTOR_ +#define FOR_0_LE_l_LT_p for (l=0; l=0; l--) +#else +#define FOR_0_LE_l_LT_p +#define FOR_p_GT_l_GE_0 +#endif + +#ifdef _HI_ORDER_ +#define FOR_0_LE_i_LT_k for (i=0; i=0; i--) +#else +#define FOR_0_LE_i_LT_k +#define FOR_k_GT_i_GE_0 +#endif + +#ifdef _HOV_ +#define FOR_0_LE_l_LT_pk1 for (l=0; l (b)) (a) = (b) + +/* END Macros */ + + +/****************************************************************************/ +/* NECESSARY INCLUDES */ +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" /* Users Parameters */ +#include "interfaces.h" +#include "adalloc.h" +#include "oplate.h" +#include "taputil.h" +#include "tayutil.h" + +#include +#include + +#ifdef __cplusplus +#include +extern "C" { +#endif + + +/****************************************************************************/ +/* NOW THE CODE */ + +/*--------------------------------------------------------------------------*/ +/* Local Static Variables */ +static short tag; + +static int rev_location_cnt; +static int dep_cnt; +static int ind_cnt; + +#ifdef _FOS_ +/****************************************************************************/ +/* First-Order Scalar Reverse Pass. */ +/****************************************************************************/ +int fos_reverse(short tnum, /* tape id */ + int depen, /* consistency chk on # of deps */ + int indep, /* consistency chk on # of indeps */ + double *lagrange, + double *results) /* coefficient vectors */ + +#elif _FOV_ +/****************************************************************************/ +/* First-Order Vector Reverse Pass. */ +/****************************************************************************/ + +int fov_reverse(short tnum, /* tape id */ + int depen, /* consistency chk on # of deps */ + int indep, /* consistency chk on # of indeps */ + int nrows, /* # of Jacobian rows being calculated */ + double **lagrange, /* domain weight vector */ + double **results) /* matrix of coefficient vectors */ + +#endif + +{ +/****************************************************************************/ +/* ALL VARIABLES */ + unsigned char operation; /* operation code */ + int tape_stats[11]; /* tape stats */ + int ret_c=3; /* return value */ + + locint size = 0; + locint res = 0; + locint arg = 0; + locint arg1 = 0; + locint arg2 = 0; + + double coval = 0, *d = 0; + + int indexi = 0, indexd = 0; + + /* loop indices */ + int i, j, l, ls; + + /* other necessary variables */ + double x, y, r0, r_0; + int buffer; + static int kax, rax, pax; + int taycheck; + int numdep,numind; + double aTmp; + +/*--------------------------------------------------------------------------*/ + /* Taylor stuff */ +#ifdef _HI_ORDER_ + static revreal **T; + static revreal *Ttemp; + revreal *Tres, *Targ, *Targ1, *Targ2, *Tqo; +#else + static revreal *T; +#endif + +/*--------------------------------------------------------------------------*/ + /* Adjoint stuff */ +#ifdef _FOS_ + static double* A; + double Atemp; +#else /* _FOV_, _HOS_, _HOV_ */ + static double** A; + static double *Atemp; +#endif + double *Ares, *Aarg, *Aarg1, *Aarg2, *Aqo; +#ifdef _HI_ORDER_ + static double *Atemp2; + double *AP1, *AP2; +#endif + +/*--------------------------------------------------------------------------*/ +#ifdef _HI_ORDER_ + int k = degre + 1; + int k1 = k + 1; + revreal comp; +#endif + +#ifdef _ADOLC_VECTOR_ + int p = nrows; +#endif + +#ifdef _HOV_ + int pk1 = p*k1; +#endif + + +#ifdef DEBUG +/****************************************************************************/ +/* DEBUG MESSAGES */ + fprintf(DIAG_OUT,"Call of %s(..) with tag: %d, n: %d, m %d,\n", + GENERATED_FILENAME, tnum, indep, depen); +#ifdef _ADOLC_VECTOR_ + fprintf(DIAG_OUT," p: %d\n\n",nrows); +#endif + +#endif + + +/****************************************************************************/ +/* INITs */ + + /*------------------------------------------------------------------------*/ + /* Set up stuff for the tape */ + + tag = tnum; /*tag is global which indicates which tape to look at */ + + tapestats(tag,tape_stats); + ind_cnt = tape_stats[0]; + dep_cnt = tape_stats[1]; + rev_location_cnt = tape_stats[2]; + buffer = tape_stats[4]; + + set_buf_size(buffer); + + if ((depen != dep_cnt)||(indep != ind_cnt)) + { fprintf(DIAG_OUT,"ADOL-C error: Reverse sweep on tape %d aborted!\n",tag); + fprintf(DIAG_OUT,"Number of dependent and/or independent variables " + "passed to reverse is\ninconsistent with number " + "recorded on tape %d \n",tag); + exit (-1); + } + + indexi = ind_cnt - 1; + indexd = dep_cnt - 1; + + +/****************************************************************************/ +/* MEMORY ALLOCATION STUFF */ + +/*--------------------------------------------------------------------------*/ +#ifdef _FOS_ /* FOS */ + if (rev_location_cnt compsize rax) + { if (rax) + { free((char*) T); + free((char*) A); + } + T = (revreal*) malloc(rev_location_cnt*sizeof(revreal)); + A = myalloc1(rev_location_cnt); + if (T == NULL) + { fprintf(DIAG_OUT,"ADOL-C error: cannot allocate %i bytes !\n", + rev_location_cnt*sizeof(revreal)); + exit (-1); + } + rax = rev_location_cnt; + } + /* olvo 980924 is following initialization necessary ??? */ + Aqo = A; + for (i=0; i0, keep=1!\n"); + exit(-2); + }; + + if((numdep != depen)||(numind != indep)) + { fprintf(DIAG_OUT, "\n ADOL-C error: reverse fails on tape %d because the" + " number of\nindependent and/or dependent variables" + " given to reverse are\ninconsistent with that of the" + " internal taylor array.\n",tag); + exit(-2); + } + + +/****************************************************************************/ +/* REVERSE SWEEP */ + + /* Initialize the Reverse Sweep */ + init_rev_sweep(tag); + + operation=get_op_r(); + while (operation != start_of_tape) + { /* Switch statement to execute the operations in Reverse */ + switch (operation) { + + +/****************************************************************************/ +/* MARKERS */ + +/*--------------------------------------------------------------------------*/ + case end_of_op: /* end_of_op */ + get_op_block_r(); + operation = get_op_r(); + /* Skip next operation, it's another end_of_op */ + break; + +/*--------------------------------------------------------------------------*/ + case end_of_int: /* end_of_int */ + get_loc_block_r(); /* Get the next int block */ + break; + +/*--------------------------------------------------------------------------*/ + case end_of_val: /* end_of_val */ + get_val_block_r(); /* Get the next val block */ + break; + +/*--------------------------------------------------------------------------*/ + case start_of_tape: /* start_of_tape */ + case end_of_tape: /* end_of_tape */ + break; + + +/****************************************************************************/ +/* COMPARISON */ + +/*--------------------------------------------------------------------------*/ + case eq_zero : /* eq_zero */ + arg = get_locint_r(); + + ret_c = 0; + break; + +/*--------------------------------------------------------------------------*/ + case neq_zero : /* neq_zero */ + case gt_zero : /* gt_zero */ + case lt_zero : /* lt_zero */ + arg = get_locint_r(); + break; + +/*--------------------------------------------------------------------------*/ + case ge_zero : /* ge_zero */ + case le_zero : /* le_zero */ + arg = get_locint_r(); + + ASSIGN_T( Targ, T[arg]) + + if (TARG == 0) + ret_c = 0; + break; + + +/****************************************************************************/ +/* ASSIGNMENTS */ + +/*--------------------------------------------------------------------------*/ + case assign_a: /* assign an adouble variable an assign_a */ + /* adouble value. (=) */ + res = get_locint_r(); + arg = get_locint_r(); + + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + { AARG_INC += ARES; + ARES_INC = 0.0; + } + + get_taylor(res); + break; + +/*--------------------------------------------------------------------------*/ + case assign_d: /* assign an adouble variable a assign_d */ + /* double value. (=) */ + res = get_locint_r(); + coval = get_val_r(); + + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + ARES_INC = 0.0; + + get_taylor(res); + break; + +/*--------------------------------------------------------------------------*/ + case assign_d_zero: /* assign an adouble variable a assign_d_zero */ + case assign_d_one: /* double value (0 or 1). (=) assign_d_one */ + res = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + ARES_INC = 0.0; + + get_taylor(res); + break; + +/*--------------------------------------------------------------------------*/ + case assign_ind: /* assign an adouble variable an assign_ind */ + /* independent double value (<<=) */ + res = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + RESULTS(l,indexi) = ARES_INC; + + get_taylor(res); + indexi--; + break; + +/*--------------------------------------------------------------------------*/ + case assign_dep: /* assign a float variable a assign_dep */ + /* dependent adouble value. (>>=) */ + res = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + ARES_INC = LAGRANGE(l,indexd); + + indexd--; + break; + + +/****************************************************************************/ +/* OPERATION + ASSIGNMENT */ + +/*--------------------------------------------------------------------------*/ + case eq_plus_d: /* Add a floating point to an eq_plus_d */ + /* adouble. (+=) */ + res = get_locint_r(); + coval = get_val_r(); + + get_taylor(res); + break; + +/*--------------------------------------------------------------------------*/ + case eq_plus_a: /* Add an adouble to another eq_plus_a */ + /* adouble. (+=) */ + res = get_locint_r(); + arg = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]); + + FOR_0_LE_l_LT_p + AARG_INC += ARES_INC; + + get_taylor(res); + break; + +/*--------------------------------------------------------------------------*/ + case eq_min_d: /* Subtract a floating point from an eq_min_d */ + /* adouble. (-=) */ + res = get_locint_r(); + coval = get_val_r(); + + get_taylor(res); + break; + +/*--------------------------------------------------------------------------*/ + case eq_min_a: /* Subtract an adouble from another eq_min_a */ + /* adouble. (-=) */ + res = get_locint_r(); + arg = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + AARG_INC -= ARES_INC; + + get_taylor(res); + break; + +/*--------------------------------------------------------------------------*/ + case eq_mult_d: /* Multiply an adouble by a eq_mult_d */ + /* flaoting point. (*=) */ + res = get_locint_r(); + coval = get_val_r(); + + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + ARES_INC *= coval; + + get_taylor(res); + break; + +/*--------------------------------------------------------------------------*/ + case eq_mult_a: /* Multiply one adouble by another eq_mult_a */ + /* (*=) */ + res = get_locint_r(); + arg = get_locint_r(); + + get_taylor(res); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + ASSIGN_T( Tres, T[res]) + ASSIGN_T( Targ, T[arg]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + /* olvo 980713 nn: ARES = 0.0; */ + ARES_INC = aTmp * TARG; + AARG_INC += aTmp * TRES; + } + break; + +/*--------------------------------------------------------------------------*/ + case incr_a: /* Increment an adouble incr_a */ + case decr_a: /* Increment an adouble decr_a */ + res = get_locint_r(); + + get_taylor(res); + break; + + +/****************************************************************************/ +/* BINARY OPERATIONS */ + +/*--------------------------------------------------------------------------*/ + case plus_a_a: /* : Add two adoubles. (+) plus a_a */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_A( Aarg2, A[arg2]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG1_INC += aTmp; + AARG2_INC += aTmp; + } + + get_taylor(res); + break; + +/*--------------------------------------------------------------------------*/ + case plus_d_a: /* Add an adouble and a double plus_d_a */ + /* (+) */ + res = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG_INC += aTmp; + } + + get_taylor(res); + break; + +/*--------------------------------------------------------------------------*/ + case min_a_a: /* Subtraction of two adoubles min_a_a */ + /* (-) */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_A( Aarg2, A[arg2]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG1_INC += aTmp; + AARG2_INC -= aTmp; + } + + get_taylor(res); + break; + +/*--------------------------------------------------------------------------*/ + case min_d_a: /* Subtract an adouble from a min_d_a */ + /* double (-) */ + res = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG_INC -= aTmp; + } + + get_taylor(res); + break; + +/*--------------------------------------------------------------------------*/ + case mult_a_a: /* Multiply two adoubles (*) mult_a_a */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + get_taylor(res); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_T( Targ1, T[arg1]) + ASSIGN_T( Targ2, T[arg2]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG2_INC += aTmp * TARG1; + AARG1_INC += aTmp * TARG2; + } + break; + +/*--------------------------------------------------------------------------*/ + /* olvo 991122: new op_code with recomputation */ + case eq_plus_prod: /* increment a product of eq_plus_prod */ + /* two adoubles (*) */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_T( Targ1, T[arg1]) + ASSIGN_T( Targ2, T[arg2]) + + /* RECOMPUTATION */ + ASSIGN_T( Tres, T[res]) + TRES -= TARG1*TARG2; + + FOR_0_LE_l_LT_p + { AARG2_INC += ARES * TARG1; + AARG1_INC += ARES_INC * TARG2; + } + break; + +/*--------------------------------------------------------------------------*/ + /* olvo 991122: new op_code with recomputation */ + case eq_min_prod: /* decrement a product of eq_min_prod */ + /* two adoubles (*) */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_T( Targ1, T[arg1]) + ASSIGN_T( Targ2, T[arg2]) + + /* RECOMPUTATION */ + ASSIGN_T( Tres, T[res]) + TRES += TARG1*TARG2; + + FOR_0_LE_l_LT_p + { AARG2_INC -= ARES * TARG1; + AARG1_INC -= ARES_INC * TARG2; + } + break; + +/*--------------------------------------------------------------------------*/ + case mult_d_a: /* Multiply an adouble by a double mult_d_a */ + /* (*) */ + res = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG_INC += coval * aTmp; + } + + get_taylor(res); + break; + +/*--------------------------------------------------------------------------*/ + case div_a_a: /* Divide an adouble by an adouble div_a_a */ + /* (/) */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_T( Tres, T[res]) + ASSIGN_T( Targ2, T[arg2]) + + /* olvo 980922 changed order to allow x=y/x */ + r_0 = -TRES; + get_taylor(res); + r0 = 1.0 / TARG2; + r_0 *= r0; + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG1_INC += aTmp * r0; + AARG2_INC += aTmp * r_0; + } + + break; + +/*--------------------------------------------------------------------------*/ + case div_d_a: /* Division double - adouble (/) div_d_a */ + res = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + ASSIGN_T( Tres, T[res]) + ASSIGN_T( Targ, T[arg]) + + /* olvo 980922 changed order to allow x=d/x */ + r0 = -TRES; + if (arg == res) + get_taylor(arg); + r0 /= TARG; + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG_INC += aTmp * r0; + } + + get_taylor(res); + break; + + +/****************************************************************************/ +/* SIGN OPERATIONS */ + +/*--------------------------------------------------------------------------*/ + case pos_sign_a: /* pos_sign_a */ + res = get_locint_r(); + arg = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG_INC += aTmp; + } + + get_taylor(res); + break; + +/*--------------------------------------------------------------------------*/ + case neg_sign_a: /* neg_sign_a */ + res = get_locint_r(); + arg = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG_INC -= aTmp; + } + + get_taylor(res); + break; + + +/****************************************************************************/ +/* UNARY OPERATIONS */ + +/*--------------------------------------------------------------------------*/ + case exp_op: /* exponent operation exp_op */ + res = get_locint_r(); + arg = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + ASSIGN_T( Tres, T[res]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG_INC += aTmp * TRES; + } + + get_taylor(res); + break; + +/*--------------------------------------------------------------------------*/ + case sin_op: /* sine operation sin_op */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_T( Targ2, T[arg2]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG1_INC += aTmp * TARG2; + } + + get_taylor(res); + get_taylor(arg2); /* olvo 980710 covalue */ + /* NOTE: A[arg2] should be 0 already */ + break; + +/*--------------------------------------------------------------------------*/ + case cos_op: /* cosine operation cos_op */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_T( Targ2, T[arg2]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG1_INC -= aTmp * TARG2; + } + + get_taylor(res); + get_taylor(arg2); /* olvo 980710 covalue */ + /* NOTE A[arg2] should be 0 already */ + break; + +/*--------------------------------------------------------------------------*/ + case atan_op: /* atan_op */ + case asin_op: /* asin_op */ + case acos_op: /* acos_op */ + case asinh_op: /* asinh_op */ + case acosh_op: /* acosh_op */ + case atanh_op: /* atanh_op */ + case erf_op: /* erf_op */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + get_taylor(res); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_T( Targ2, T[arg2]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG1_INC += aTmp * TARG2; + } + break; + +/*--------------------------------------------------------------------------*/ + case log_op: /* log_op */ + res = get_locint_r(); + arg = get_locint_r(); + + get_taylor(res); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + ASSIGN_T( Targ, T[arg]) + + r0 = 1.0/TARG; + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG_INC += aTmp * r0; + } + break; + +/*--------------------------------------------------------------------------*/ + case pow_op: /* pow_op */ + res = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + ASSIGN_T( Tres, T[res]) + ASSIGN_T( Targ, T[arg]) + + /* olvo 980921 changed order to allow x=pow(x,n) */ + r0 = TRES; + if (arg == res) + get_taylor(arg); + if (TARG == 0.0) + r0 = 0.0; + else + r0 *= coval/TARG; + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG_INC += aTmp * r0; + } + + get_taylor(res); + break; + +/*--------------------------------------------------------------------------*/ + case sqrt_op: /* sqrt_op */ + res = get_locint_r(); + arg = get_locint_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + ASSIGN_T( Tres, T[res]) + + if (TRES == 0.0) + r0 = 0.0; + else + r0 = 0.5 / TRES; + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG_INC += aTmp * r0; + } + + get_taylor(res); + break; + +/*--------------------------------------------------------------------------*/ + case gen_quad: /* gen_quad */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + coval = get_val_r(); + coval = get_val_r(); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_T( Targ2, T[arg2]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG1_INC += aTmp * TARG2; + } + + get_taylor(res); + break; + +/*--------------------------------------------------------------------------*/ + case min_op: /* min_op */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + coval = get_val_r(); + + get_taylor(res); + + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Ares, A[res]) + ASSIGN_T( Targ1, T[arg1]) + ASSIGN_T( Targ2, T[arg2]) + + if (TARG1 > TARG2) + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + if ((coval) && (aTmp)) + MINDEC(ret_c,2); + AARG2_INC += aTmp; + } + else + if (TARG1 < TARG2) + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + if ((!coval) && (aTmp)) + MINDEC(ret_c,2); + AARG1_INC += aTmp; + } + else + { /* both are equal */ + FOR_0_LE_l_LT_p + { aTmp = ARES / 2.0; + ARES_INC = 0.0; + AARG2_INC += aTmp; + AARG1_INC += aTmp; + } + if (arg1 != arg2) + MINDEC(ret_c,1); + } + break; + +/*--------------------------------------------------------------------------*/ + case abs_val: /* abs_val */ + res = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + get_taylor(res); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + ASSIGN_T( Targ, T[arg]) + + if (TARG < 0.0) + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + if ((coval) && (aTmp)) + MINDEC(ret_c,2); + AARG_INC -= aTmp; + } + else + if (TARG > 0.0) + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + if ((!coval) && (aTmp)) + MINDEC(ret_c,2); + AARG_INC += aTmp; + } + else + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + if (aTmp) + MINDEC(ret_c,1); + } + break; + +/*--------------------------------------------------------------------------*/ + case ceil_op: /* ceil_op */ + res = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + get_taylor(res); + + ASSIGN_A( Ares, A[res]) + ASSIGN_T( Targ, T[arg]) + + coval = (coval != ceil(TARG) ); + + FOR_0_LE_l_LT_p + { if ((coval) && (ARES)) + MINDEC(ret_c,2); + ARES_INC = 0.0; + } + break; + +/*--------------------------------------------------------------------------*/ + case floor_op: /* floor_op */ + res = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + get_taylor(res); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + ASSIGN_T( Targ, T[arg]) + + coval = ( coval != floor(TARG1) ); + + FOR_0_LE_l_LT_p + { if ( (coval) && (ARES) ) + MINDEC(ret_c,2); + ARES_INC = 0.0; + } + break; + + +/****************************************************************************/ +/* CONDITIONALS */ + +/*--------------------------------------------------------------------------*/ + case cond_assign: /* cond_assign */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + get_taylor(res); + + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_T( Targ, T[arg]) + + /* olvo 980924 changed code a little bit */ + if (TARG > 0.0) + { if (res != arg1) + FOR_0_LE_l_LT_p + { if ((coval <= 0.0) && (ARES)) + MINDEC(ret_c,2); + AARG1_INC += ARES; + ARES_INC = 0.0; + } + else + FOR_0_LE_l_LT_p + if ((coval <= 0.0) && (ARES_INC)) + MINDEC(ret_c,2); + } + else + { if (res != arg2) + FOR_0_LE_l_LT_p + { if ((coval <= 0.0) && (ARES)) + MINDEC(ret_c,2); + AARG2_INC += ARES; + ARES_INC = 0.0; + } + else + FOR_0_LE_l_LT_p + if ((coval <= 0.0) && (ARES_INC)) + MINDEC(ret_c,2); + } + break; + +/*--------------------------------------------------------------------------*/ + case cond_assign_s: /* cond_assign_s */ + res = get_locint_r(); + arg1 = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + get_taylor(res); + + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_A( Ares, A[res]) + ASSIGN_T( Targ, T[arg]) + + /* olvo 980924 changed code a little bit */ + if (TARG > 0.0) + { if (res != arg1) + FOR_0_LE_l_LT_p + { if ((coval <= 0.0) && (ARES)) + MINDEC(ret_c,2); + AARG1_INC += ARES; + ARES_INC = 0.0; + } + else + FOR_0_LE_l_LT_p + if ((coval <= 0.0) && (ARES_INC)) + MINDEC(ret_c,2); + } + else + if (TARG == 0.0) /* we are at the tie */ + FOR_0_LE_l_LT_p + if (ARES_INC) + MINDEC(ret_c,0); + break; + + +/****************************************************************************/ +/* VECTOR ASSIGNMENTS */ + +/*--------------------------------------------------------------------------*/ + case assign_av: /* assign_av */ + res = get_locint_r(); + size = get_locint_r(); + arg = get_locint_r(); + + res += size; + arg += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of left-hand-side */ + arg--; /* Location of right-hand-side */ + + /* code for assign_a */ + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + { AARG_INC += ARES; + ARES_INC = 0.0; + } + + get_taylor(res); + } + break; + +/*--------------------------------------------------------------------------*/ + case assign_dv: /* assign_dv */ + res = get_locint_r(); + size = get_locint_r(); + d = get_val_v_r(size); + + res += size; + d += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of left-hand-side */ + coval = *(--d); /* Value of right-hand-side */ + + /* code for assign_d */ + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + ARES_INC = 0.0; + + get_taylor(res); + } + break; + +/*--------------------------------------------------------------------------*/ + case assign_indvec: /* assign_indvec */ + res = get_locint_r(); + size = get_locint_r(); + + res += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of the left-hand-side */ + + /* code for assign_ind */ + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + RESULTS(l,indexi) = ARES_INC; + indexi--; + + get_taylor(res); + } + reset_val_r(); + break; + +/*--------------------------------------------------------------------------*/ + case assign_depvec: /* assign_depvec */ + res = get_locint_r(); + size = get_locint_r(); + + res += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of the left-hand-side */ + + /* code for assign_dep */ + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + ARES_INC = LAGRANGE(l, indexd); + indexd--; + } + break; + + +/****************************************************************************/ +/* VECTOR OPERATION + ASSIGNMENT */ + +/*--------------------------------------------------------------------------*/ + case eq_plus_av: /* eq_plus_av */ + res = get_locint_r(); + size = get_locint_r(); + arg = get_locint_r(); + + res += size; + arg += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of left-hand-side */ + arg--; /* Location on right-hand-side */ + + /* code for eq_plus_a */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A (Aarg, A[arg]) + + FOR_0_LE_l_LT_p + AARG_INC += ARES_INC; + + get_taylor(res); + } + break; + +/*--------------------------------------------------------------------------*/ + case eq_min_av: /* eq_min_av */ + res = get_locint_r(); + size = get_locint_r(); + arg = get_locint_r(); + + res += size; + arg += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of left-hand-side */ + arg--; /* Location on right-hand-side */ + + /* code for eq_min_a */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + AARG_INC -= ARES_INC; + + get_taylor(res); + } + break; + +/*--------------------------------------------------------------------------*/ + case eq_mult_av_d: /* eq_mult_av_d */ + res = get_locint_r(); + size = get_locint_r(); + coval = get_val_r(); + + res += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of the left-hand-side */ + /* coval = fixed; value on the right-hand-side */ + + /* code for eq_mult_d*/ + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + ARES_INC *= coval; + + get_taylor(res); + } + break; + +/*--------------------------------------------------------------------------*/ + case eq_mult_av_a: /* eq_mult_av_a */ + res = get_locint_r(); + size = get_locint_r(); + arg = get_locint_r(); + + /* olvo 980929 new strategy to check for overwrites + (changes computation order) */ + if ((arg >= res) && (arg < res+size)) + { /* FIRST compute the case: res==arg */ + /* simplified code for eq_mult_a*/ + get_taylor(arg); + + ASSIGN_A( Aarg, A[arg]) + ASSIGN_T( Targ, T[arg]) + + FOR_0_LE_l_LT_p + AARG_INC *= 2.0 * TARG; + } + + res += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of the left-hand-side */ + /* arg = fixed; Location on the right-hand-side */ + + if (res == arg) /* NOW skip this case */ + continue; + + /* code for eq_mult_a*/ + get_taylor(res); + + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Ares, A[res]) + ASSIGN_T( Tres, T[res]) + ASSIGN_T( Targ, T[arg]) + + FOR_0_LE_l_LT_p + { r0 = ARES; + /* olvo 980713 nn: ARES = 0; */ + ARES_INC = r0 * TARG; + AARG_INC += r0 * TRES; + } + } + break; + + +/****************************************************************************/ +/* BINARY VECTOR OPERATIONS */ + +/*--------------------------------------------------------------------------*/ + case plus_av_av: /* plus_av_av */ + res = get_locint_r(); + size = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + res += size; + arg1 += size; + arg2 += size; + for (ls=size; ls>0; ls--) + { arg2--; /* Location of var 2 */ + arg1--; /* Location of var 1 */ + res--; /* Location of result */ + + /* code for plus_a_a */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_A( Aarg2, A[arg2]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG1_INC += aTmp; + AARG2_INC += aTmp; + } + + get_taylor(res); + } + break; + +/*--------------------------------------------------------------------------*/ + case sub_av_av: /* sub_av_av */ + res = get_locint_r(); + size = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + res += size; + arg1 += size; + arg2 += size; + for (ls=size; ls>0; ls--) + { arg2--; /* Location of var 2 */ + arg1--; /* Location of var 1 */ + res--; /* Location of result */ + + /* code for min_a_a */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_A( Aarg2, A[arg2]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG1_INC += aTmp; + AARG2_INC -= aTmp; + } + + get_taylor(res); + } + break; + +/*--------------------------------------------------------------------------*/ + case dot_av_av: /* dot_av_av */ + res = get_locint_r(); + size = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + get_taylor(res); + + /* save Ares to Atemp */ + ASSIGN_A( Aqo, Atemp) + ASSIGN_A( Ares, A[res]) + FOR_0_LE_l_LT_p + { AQO_INC = ARES; + ARES_INC = 0.0; + } + + for (ls=0; ls= res) && (arg2 < res+size)) + { /* FIRST compute the case: res==arg2 */ + /* simplified code for mult_a_a */ + get_taylor(arg2); + + ASSIGN_A( Aarg1, A[arg1+res-arg2]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_T( Targ2, T[arg2]) + ASSIGN_T( Targ1, T[arg1+res-arg2]) + + FOR_0_LE_l_LT_p + { AARG1_INC += AARG2 * TARG2; + AARG2_INC *= TARG1; + } + } + + res += size; + arg1 += size; + for (ls=size; ls>0; ls--) + { arg1--; /* Location of rght hnd side vectore[l] */ + res--; /* Location of the result */ + + if (res == arg2) /* NOW skip this case */ + continue; + + /* code for mult_a_a */ + get_taylor(res); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_T( Targ1, T[arg1]) + ASSIGN_T( Targ2, T[arg2]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG2_INC += aTmp * TARG1; + AARG1_INC += aTmp * TARG2; + } + } + break; + +/*--------------------------------------------------------------------------*/ + case mult_d_av: /* mult_d_av */ + res = get_locint_r(); + size = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + res += size; + arg += size; + for (ls=size; ls>0; ls--) + { arg--; /* Location on the right-hand-side */ + res--; /* location of the result */ + /* coval = Fixed double value */ + + /* code for mult_d_a */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG_INC += coval * aTmp; + } + + get_taylor(res); + } + break; + +/*--------------------------------------------------------------------------*/ + case div_av_a: /* div_av_a */ + res = get_locint_r(); + size = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + /* olvo 980929 new strategy to check for overwrites + (changes computation order) */ + if ((arg2 >= res) && (arg2 < res+size)) + { /* FIRST compute the case: res==arg2 */ + /* code for div_a_a */ + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Aarg1, A[arg1+res-arg2]) + ASSIGN_T( Targ2, T[arg2]) + + /* olvo 980922 changed order to allow x=y/x */ + r_0 = -TARG2; + get_taylor(arg2); + r0 = 1.0 / TARG2; + r_0 *= r0; + + FOR_0_LE_l_LT_p + { AARG1_INC += AARG2 * r0; + AARG2_INC *= r_0; + } + } + + res += size; + arg1 += size; + for (ls=size; ls>0; ls--) + { arg1--; /* Location of right-hand-side vector[l] */ + res--; /* Location of the result */ + + if (res == arg2) /* NOW skip this case */ + continue; + + /* code for div_a_a */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_T( Tres, T[res]) + ASSIGN_T( Targ2, T[arg2]) + + /* olvo 980922 changed order to allow x=y/x */ + r_0 = -TRES; + get_taylor(res); + r0 = 1.0 / TARG2; + r_0 *= r0; + + FOR_0_LE_l_LT_p + { aTmp = ARES; + ARES_INC = 0.0; + AARG1_INC += aTmp * r0; + AARG2_INC += aTmp * r_0; + } + } + break; + + +/****************************************************************************/ +/* SUBSCRIPTS */ + +/*--------------------------------------------------------------------------*/ + case subscript: /* subscript */ + res = get_locint_r(); + arg1 = get_locint_r(); + arg2 = get_locint_r(); + coval = get_val_r(); + + ASSIGN_T( Targ1, T[arg1]) + + arg = arg2 + (int)(TARG1); + + /* olvo 980721 new nl */ + get_taylor(res); + + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + { if (((int)(coval) != (int)(TARG1)) && (ARES)) + MINDEC(ret_c,2); + + AARG_INC += ARES; + if (arg != res) + ARES_INC = 0; + else + ARES_INC; + } + + break; + +/*--------------------------------------------------------------------------*/ + case subscript_l: /* subscript_l */ + arg = get_locint_r(); + arg1 = get_locint_r(); + arg2 = get_locint_r(); + coval = get_val_r(); + + ASSIGN_T( Targ1, T[arg1]) + + res = arg2 + (int)(TARG1); + + get_taylor(res); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + { if (((int)(coval) != (int)(TARG1)) && (ARES)) + MINDEC(ret_c,2); + + AARG_INC += ARES; + if(arg != res) + ARES_INC = 0; + else + ARES_INC; + } + break; + +/*--------------------------------------------------------------------------*/ + case subscript_ld: /* subscript_ld */ + arg1 = get_locint_r(); + arg2 = get_locint_r(); + coval = get_val_r(); + coval = get_val_r(); + + ASSIGN_T( Targ1, T[arg1]) + + arg = arg2 + (int)(TARG1); + + get_taylor(arg); + + if((int)(coval)!=(int)(TARG1)) + MINDEC(ret_c,2); + + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + AARG_INC = 0.0; + break; + +/*--------------------------------------------------------------------------*/ + case m_subscript: /* m_subscript */ + res = get_locint_r(); + size = get_locint_r(); + arg1 = get_locint_r(); + arg2 = get_locint_r(); + coval = get_val_r(); + + ASSIGN_T( Targ1, T[arg1]) + + arg = arg2 + ((int)(TARG1) + 1)*size; + res += size; + for (ls=size; ls>0; ls--) + { res--; arg--; + + /* olvo 980721 new nl */ + get_taylor(res); + + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + { if (((int)(coval)!=(int)(TARG1)) && (ARES)) + MINDEC(ret_c,2); + AARG_INC += ARES; + if (arg != res) + ARES_INC = 0; + else + ARES_INC; + } + } + break; + +/*--------------------------------------------------------------------------*/ + case m_subscript_l: /* m_subscript_l */ + arg = get_locint_r(); + size = get_locint_r(); + arg1 = get_locint_r(); + arg2 = get_locint_r(); + coval = get_val_r(); + + ASSIGN_T( Targ1, T[arg1]) + + res = arg2 + ((int)(TARG1) + 1)*size; + arg += size; + for (ls=size; ls>0; ls--) + { arg--; res--; + + get_taylor(res); + + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + { if (((int)(coval) != (int)(TARG1)) && (ARES)) + MINDEC(ret_c,2); + AARG_INC += ARES; + if (arg != res) + ARES_INC = 0; + else + ARES_INC; + } + } + break; + +/*--------------------------------------------------------------------------*/ + case m_subscript_ld: /* m_subscript_ld */ + size = get_locint_r(); + arg = get_locint_r(); + arg1 = get_locint_r(); + arg2 = get_locint_r(); + /* olvo 980702 changed n2l */ + d = get_val_v_r(size); + coval = get_val_r(); + + ASSIGN_T( Targ1, T[arg1]) + + if ((int)(coval) != (int)(TARG1)) + MINDEC(ret_c,2); + + res = arg2 + ((int)(TARG1) + 1)*size + arg; + for (ls=size; ls>0; ls--) + { res--; + + get_taylor(res); + + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + ARES_INC = 0.0; + } + break; + + +/****************************************************************************/ +/* REMAINING STUFF */ + +/*--------------------------------------------------------------------------*/ + case take_stock_op: /* take_stock_op */ + res = get_locint_r(); + size = get_locint_r(); + d = get_val_v_r(size); + + res += size; + for (ls=size; ls>0; ls--) + { res--; + + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + ARES_INC = 0.0; + } + break; + +/*--------------------------------------------------------------------------*/ + case death_not: /* death_not */ + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + for (j=arg1;j<=arg2;j++) + { ASSIGN_A(Aarg1, A[j]) + + FOR_0_LE_l_LT_p + AARG1_INC = 0.0; + + get_taylor(j); + } + break; + +/*--------------------------------------------------------------------------*/ + default: /* default */ + /* Die here, we screwed up */ + + fprintf(DIAG_OUT,"ADOL-C fatal error in " GENERATED_FILENAME " (" + __FILE__ + ") : no such operation %d\n", operation); + exit(-1); + break; + } /* endswitch */ + + /* Get the next operation */ + operation=get_op_r(); + } /* endwhile */ + + end_sweep(); + return ret_c; +} + + +/****************************************************************************/ +/* THAT'S ALL */ +#ifdef __cplusplus +} +#endif + +#undef _ADOLC_SRC_ +#undef _FO_REV_C_ + + diff --git a/adol-c/SRC/fortutils.c b/adol-c/SRC/fortutils.c new file mode 100644 index 0000000..05fac13 --- /dev/null +++ b/adol-c/SRC/fortutils.c @@ -0,0 +1,87 @@ +#define _FORTUTILSS_C_ +#define _ADOLC_SRC_ +/* + ---------------------------------------------------------------- + File fortutils.c of ADOL-C version 1.8.0 as of Nov/30/98 + ---------------------------------------------------------------- + Internal tools to handle Fortran arrays + + Last changed : + 981130 olvo newly created from driversc.c + + ---------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/* INCLUDES */ +#include "dvlparms.h" +#include "usrparms.h" +#include "fortutils.h" + +#ifdef __cplusplus +extern "C" { +#endif + + +/****************************************************************************/ +/* ROUTINES TO USE WITH ADOL-F */ + +/*--------------------------------------------------------------------------*/ +void spread1(int m, fdouble* x, double* X) +{ int j; + for (j=0; j Aqo) + (2) new macros AQO* + (3) deleted all int_* opcodes + 980923 olvo allow reflexive operations for + - min_op + 980922 olvo (1) allow reflexive operations for + - div_d_a, div_a_a + 980921 olvo (1) changed save-order in sin/cos + (2) allow reflexive operations for + - pow + (3) new macros VEC_COMPUTED_* + 980820 olvo new comparison strategy + 980721 olvo write of taylors in subscript and + subscript_m + 980714 olvo some error elimination + op-code mult_av_a removed + 980713 olvo debugging & optimizing + 980710 olvo sin/cos writes 2 taylors + 980709 olvo new operation code: neg_sign_a + pos_sign_a + 980706 olvo new operation code: int_adb_d_one + int_adb_d_zero + 980703 olvo new operation code: assign_d_one + assign_d_zero + 980626 olvo vector operations & subscripts + 980623 mitev/olvo revision + stock stuff + 980622 olvo debugging & rearrangements + 980616 olvo griewank's idea II + 980615 olvo griewank's idea + 980612 mitev + + ----------------------------------------------------------------- +*/ + +/* + ----------------------------------------------------------------- + There are four basic versions of the procedure `reverse', which + are optimized for the cases of scalar or vector reverse sweeps + with first or higher derivatives, respectively. In the calling + sequence this distinction is apparent from the type of the + parameters `lagrange' and `results'. The former may be left out + and the integer parameters `depen', `indep', `degre', and `nrows' + must be set or default according to the following matrix of + calling cases. + + no lagrange double* lagrange double** lagrange + +double* gradient of scalar weight vector times infeasible +results valued function Jacobian product combination + + ( depen = 1 , ( depen > 0 , + degre = 0 , degre = 0 , ------ + nrows = 1 ) nrows = 1 ) + +double** Jacobian of vector weight vector times weight matrix +results valued function Taylor-Jacobians times Jacobian + + ( 0 < depen ( depen > 0 , ( depen > 0 , + = nrows , degre > 0 , degre = 0 , + degre = 0 ) nrows = 1 ) nrows > 0 ) + +double*** full family of ------------ weigth matrix x +results Taylor-Jacobians ------------ Taylor Jacobians + ----------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/* MACROS */ +#undef _ADOLC_VECTOR_ +#undef _HI_ORDER_ + +/*--------------------------------------------------------------------------*/ +#ifdef _HOS_ +#define GENERATED_FILENAME "hos_reverse" + +#define _HI_ORDER_ + +#define RESULTS(l,indexi,k) results[indexi][k] +#define LAGRANGE(l,indexd) lagrange[indexd] + +#define HOV_INC(T,degree) {} + +/*--------------------------------------------------------------------------*/ +#elif _HOV_ +#define GENERATED_FILENAME "hov_reverse" + +#define _ADOLC_VECTOR_ +#define _HI_ORDER_ + +#define RESULTS(l,indexi,k) results[l][indexi][k] +#define LAGRANGE(l,indexd) lagrange[l][indexd] + +#define IF_HOV_ +#define ENDIF_HOV_ + +#define HOV_INC(T,degree) T += degree; + +#else +#error Error ! Define [_HOS_ | _HOV_] +#endif + +/*--------------------------------------------------------------------------*/ +/* access to variables */ + +#ifdef _FOS_ +#define ARES *Ares +#define AARG *Aarg +#define AARG1 *Aarg1 +#define AARG2 *Aarg2 +#define AQO *Aqo + +#define ARES_INC *Ares +#define AARG_INC *Aarg +#define AARG1_INC *Aarg1 +#define AARG2_INC *Aarg2 +#define AQO_INC *Aqo + +#define ARES_INC_O Ares +#define AARG_INC_O Aarg +#define AARG1_INC_O Aarg1 +#define AARG2_INC_O Aarg2 +#define AQO_INC_O Aqo + +#define ASSIGN_A(a,b) a = &b; + +#else /* _FOV_, _HOS_, _HOV_ */ +#define ARES *Ares +#define AARG *Aarg +#define AARG1 *Aarg1 +#define AARG2 *Aarg2 +#define AQO *Aqo + +#define ARES_INC *Ares++ +#define AARG_INC *Aarg++ +#define AARG1_INC *Aarg1++ +#define AARG2_INC *Aarg2++ +#define AQO_INC *Aqo++ + +#define ARES_INC_O Ares++ +#define AARG_INC_O Aarg++ +#define AARG1_INC_O Aarg1++ +#define AARG2_INC_O Aarg2++ +#define AQO_INC_O Aqo++ + +#define ASSIGN_A(a,b) a = b; +#endif + +#ifdef _HI_ORDER_ + +#define TRES *Tres +#define TARG *Targ +#define TARG1 *Targ1 +#define TARG2 *Targ2 + +#define ASSIGN_T(a,b) a = b; +#else + +#define TRES T[res] +#define TARG T[arg] +#define TARG1 T[arg1] +#define TARG2 T[arg2] + +#define ASSIGN_T(a,b) +#endif + +/*--------------------------------------------------------------------------*/ +/* loop stuff */ +#ifdef _ADOLC_VECTOR_ +#define FOR_0_LE_l_LT_p for (l=0; l=0; l--) +#else +#define FOR_0_LE_l_LT_p +#define FOR_p_GT_l_GE_0 +#endif + +#ifdef _HI_ORDER_ +#define FOR_0_LE_i_LT_k for (i=0; i=0; i--) +#else +#define FOR_0_LE_i_LT_k +#define FOR_k_GT_i_GE_0 +#endif + +#ifdef _HOV_ +#define FOR_0_LE_l_LT_pk1 for (l=0; l (b)) (a) = (b) + +/* END Macros */ + + +/****************************************************************************/ +/* NECESSARY INCLUDES */ +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" /* Users Parameters */ +#include "interfaces.h" +#include "adalloc.h" +#include "oplate.h" +#include "taputil.h" +#include "tayutil.h" +#include "convolut.h" + +#include +#include + +#ifdef __cplusplus +#include +extern "C" { +#endif + + +/****************************************************************************/ +/* NOW THE CODE */ + +/*--------------------------------------------------------------------------*/ +/* Local Static Variables */ +static short tag; + +static int rev_location_cnt; +static int dep_cnt; +static int ind_cnt; + +#ifdef _HOS_ +/***************************************************************************/ +/* Higher Order Scalar Reverse Pass. */ +/***************************************************************************/ +int hos_reverse(short tnum, /* tape id */ + int depen, /* consistency chk on # of deps */ + int indep, /* consistency chk on # of indeps */ + int degre, /* highest derivative degre */ + double *lagrange, /* range weight vector */ + double **results) /* matrix of coefficient vectors */ + +#elif _HOV_ +/***************************************************************************/ +/* Higher Order Vector Reverse Pass. */ +/***************************************************************************/ +int hov_reverse(short tnum, /* tape id */ + int depen, /* consistency chk on # of deps */ + int indep, /* consistency chk on # of indeps */ + int degre, /* highest derivative degre */ + int nrows, /* # of Jacobian rows calculated */ + double **lagrange, /* domain weight vector */ + double ***results, /* matrix of coefficient vectors */ + short **nonzero ) /* structural sparsity pattern */ + +#endif + +{ +/****************************************************************************/ +/* ALL VARIABLES */ + unsigned char operation; /* operation code */ + int tape_stats[11]; /* tape stats */ + int ret_c=3; + + locint size = 0; + locint res = 0; + locint arg = 0; + locint arg1 = 0; + locint arg2 = 0; + + double coval = 0, *d = 0; + + int indexi = 0, indexd = 0; + + /* loop indices */ + int i, j, l, ls; + + /* other necessary variables */ + double x, y, r0, r_0; + int buffer; + static int kax, rax, pax; + int taycheck; + int numdep,numind; + double aTmp; + +/*--------------------------------------------------------------------------*/ + /* Taylor stuff */ +#ifdef _HI_ORDER_ + static revreal **T; + static revreal *Ttemp; + static revreal *Ttemp2; + revreal *Tres, *Targ, *Targ1, *Targ2, *Tqo; +#else + static revreal *T; +#endif + +/*--------------------------------------------------------------------------*/ + /* Adjoint stuff */ +#ifdef _FOS_ + static double* A; + double Atemp; +#else /* _FOV_, _HOS_, _HOV_ */ + static double** A; + static double *Atemp; +#endif + double *Ares, *Aarg, *Aarg1, *Aarg2, *Aqo; +#ifdef _HI_ORDER_ + static double *Atemp2; + double *AP1, *AP2; +#endif + +/*--------------------------------------------------------------------------*/ +#ifdef _HI_ORDER_ + int k = degre + 1; + int k1 = k + 1; + revreal comp; +#endif + +#ifdef _ADOLC_VECTOR_ + int p = nrows; + int computed; +#endif + +#ifdef _HOV_ + int pk1 = p*k1; +#endif + + +#ifdef DEBUG +/****************************************************************************/ +/* DEBUG MESSAGES */ + fprintf(DIAG_OUT,"Call of %s(..) with tag: %d, n: %d, m %d,\n", + GENERATED_FILENAME, tnum, indep, depen); + +#ifdef _HI_ORDER_ + fprintf(DIAG_OUT," degree: %d\n",degre); +#endif +#ifdef _ADOLC_VECTOR_ + fprintf(DIAG_OUT," p: %d\n\n",nrows); +#endif + +#endif + + +/****************************************************************************/ +/* INITs */ + + /*------------------------------------------------------------------------*/ + /* Set up stuff for the tape */ + + tag = tnum; /*tag is global which indicates which tape to look at */ + + tapestats(tag,tape_stats); + ind_cnt = tape_stats[0]; + dep_cnt = tape_stats[1]; + rev_location_cnt = tape_stats[2]; + buffer = tape_stats[4]; + + set_buf_size(buffer); + + if ((depen != dep_cnt)||(indep != ind_cnt)) + { fprintf(DIAG_OUT,"ADOL-C error: Reverse sweep on tape %d aborted!\n",tag); + fprintf(DIAG_OUT,"Number of dependent and/or independent variables " + "passed to reverse is\ninconsistent with number " + "recorded on tape %d \n",tag); + exit (-1); + } + + indexi = ind_cnt - 1; + indexd = dep_cnt - 1; + + +/****************************************************************************/ +/* MEMORY ALLOCATION STUFF */ + +/*--------------------------------------------------------------------------*/ +#ifdef _HOS_ /* HOS */ + if (k compsize kax || rev_location_cnt compsize rax) + { if (rax || kax) + { free((char*) Atemp); + free((char*) Atemp2); + free((char*) Ttemp); + free((char*) *T); free((char*) T); + free((char*) *A); free((char*) A); + } + Atemp = myalloc1(k1); + Atemp2 = myalloc1(k1); + A = myalloc2(rev_location_cnt,k1); + Ttemp = (revreal *)malloc(k*sizeof(revreal)); + Ttemp2 = (revreal *)malloc(k*sizeof(revreal)); + T = (revreal**)malloc(rev_location_cnt*sizeof(revreal*)); + Tqo = (revreal *)malloc(rev_location_cnt*k*sizeof(revreal)); + if ((T == NULL)||(Tqo == NULL)||(Ttemp == NULL)) + { fprintf(DIAG_OUT,"ADOL-C error: cannot allocate %i + %i + %i bytes!\n", + k*sizeof(revreal),rev_location_cnt*sizeof(revreal*), + rev_location_cnt*k*sizeof(revreal)); + exit (-1); + } + for(i=0;i%i," + " keep=%i!\n",degre,degre+1); + exit(-2); + }; + + if((numdep != depen)||(numind != indep)) + { fprintf(DIAG_OUT,"\n ADOL-C error: reverse fails on tape %d because the" + " number of\nindependent and/or dependent variables" + " given to reverse are\ninconsistent with that of the" + " internal taylor array.\n",tag); + exit(-2); + } + + +/****************************************************************************/ +/* REVERSE SWEEP */ + + /* Initialize the Reverse Sweep */ + init_rev_sweep(tag); + + operation=get_op_r(); + while (operation != start_of_tape) + { /* Switch statement to execute the operations in Reverse */ + switch (operation) { + + +/****************************************************************************/ +/* MARKERS */ + +/*--------------------------------------------------------------------------*/ + case end_of_op: /* end_of_op */ + get_op_block_r(); + operation = get_op_r(); + /* Skip next operation, it's another end_of_op */ + break; + +/*--------------------------------------------------------------------------*/ + case end_of_int: /* end_of_int */ + get_loc_block_r(); /* Get the next int block */ + break; + +/*--------------------------------------------------------------------------*/ + case end_of_val: /* end_of_val */ + get_val_block_r(); /* Get the next val block */ + break; + +/*--------------------------------------------------------------------------*/ + case start_of_tape: /* start_of_tape */ + case end_of_tape: /* end_of_tape */ + break; + + +/****************************************************************************/ +/* COMPARISON */ + +/*--------------------------------------------------------------------------*/ + case eq_zero : /* eq_zero */ + arg = get_locint_r(); + + ret_c = 0; + break; + +/*--------------------------------------------------------------------------*/ + case neq_zero : /* neq_zero */ + case gt_zero : /* gt_zero */ + case lt_zero : /* lt_zero */ + arg = get_locint_r(); + break; + +/*--------------------------------------------------------------------------*/ + case ge_zero : /* ge_zero */ + case le_zero : /* le_zero */ + arg = get_locint_r(); + + if (*T[arg] == 0) + ret_c = 0; + break; + + +/****************************************************************************/ +/* ASSIGNMENTS */ + +/*--------------------------------------------------------------------------*/ + case assign_a: /* assign an adouble variable an assign_a */ + /* adouble value. (=) */ + res = get_locint_r(); + arg = get_locint_r(); + + ASSIGN_A(Aarg, A[arg]) + ASSIGN_A(Ares, A[res]) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Aarg, k1) + HOV_INC(Ares, k1) + } + else + { MAXINC(AARG,ARES); + AARG_INC_O; ARES_INC = 0.0; + FOR_0_LE_i_LT_k + { /* ! no tempory */ + AARG_INC += ARES; + ARES_INC = 0.0; + } + } + + get_taylors(res,k); + break; + +/*--------------------------------------------------------------------------*/ + case assign_d: /* assign an adouble variable a assign_d */ + /* double value. (=) */ + res = get_locint_r(); + coval = get_val_r(); + + ASSIGN_A(Ares, A[res]) + + FOR_0_LE_l_LT_pk1 + ARES_INC = 0.0; + + get_taylors(res,k); + break; + +/*--------------------------------------------------------------------------*/ + case assign_d_zero: /* assign an adouble variable a assign_d_zero */ + case assign_d_one: /* double value. (=) assign_d_one */ + res = get_locint_r(); + + ASSIGN_A(Ares, A[res]) + + FOR_0_LE_l_LT_pk1 + ARES_INC = 0.0; + + get_taylors(res,k); + break; + +/*--------------------------------------------------------------------------*/ + case assign_ind: /* assign an adouble variable an assign_ind */ + /* independent double value (<<=) */ + res = get_locint_r(); + + ASSIGN_A(Ares, A[res]) + + FOR_0_LE_l_LT_p + { +#ifdef _HOV_ + if (nonzero) /* ??? question: why here? */ + nonzero[l][indexi] = (int)ARES; +#endif /* _HOV_ */ + ARES_INC_O; + FOR_0_LE_i_LT_k + RESULTS(l,indexi,i) = ARES_INC; + } + + get_taylors(res,k); + indexi--; + break; + +/*--------------------------------------------------------------------------*/ + case assign_dep: /* assign a float variable a assign_dep */ + /* dependent adouble value. (>>=) */ + res = get_locint_r(); + + ASSIGN_A(Ares, A[res]) + + FOR_0_LE_l_LT_p + { *(++Ares) = LAGRANGE(l,indexd); + + if (ARES) + *(--Ares) = 1.0; + else + --Ares; + HOV_INC(Ares, k1) + } + indexd--; + break; + + +/****************************************************************************/ +/* OPERATION + ASSIGNMENT */ + +/*--------------------------------------------------------------------------*/ + case eq_plus_d: /* Add a floating point to an eq_plus_d */ + /* adouble. (+=) */ + res = get_locint_r(); + coval = get_val_r(); + + get_taylors(res,k); + break; + +/*--------------------------------------------------------------------------*/ + case eq_plus_a: /* Add an adouble to another eq_plus_a */ + /* adouble. (+=) */ + res = get_locint_r(); + arg = get_locint_r(); + + ASSIGN_A(Ares, A[res]) + ASSIGN_A(Aarg, A[arg]); + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg, k1) + } + else + { MAXINC(AARG,ARES); + AARG_INC_O; ARES_INC_O; + FOR_0_LE_i_LT_k + AARG_INC += ARES_INC; + } + + get_taylors(res,k); + break; + +/*--------------------------------------------------------------------------*/ + case eq_min_d: /* Subtract a floating point from an eq_min_d */ + /* adouble. (-=) */ + res = get_locint_r(); + coval = get_val_r(); + + get_taylors(res,k); + break; + +/*--------------------------------------------------------------------------*/ + case eq_min_a: /* Subtract an adouble from another eq_min_a */ + /* adouble. (-=) */ + res = get_locint_r(); + arg = get_locint_r(); + + ASSIGN_A(Ares, A[res]) + ASSIGN_A(Aarg, A[arg]) + + FOR_0_LE_l_LT_p + if (0==ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg, k1) + } + else + { MAXINC(AARG,ARES); + AARG_INC_O; ARES_INC_O; + FOR_0_LE_i_LT_k + AARG_INC -= ARES_INC; + } + + get_taylors(res,k); + break; + +/*--------------------------------------------------------------------------*/ + case eq_mult_d: /* Multiply an adouble by a eq_mult_d */ + /* flaoting point. (*=) */ + res = get_locint_r(); + coval = get_val_r(); + + ASSIGN_A(Ares, A[res]) + + FOR_0_LE_l_LT_p + if ( 0 == ARES_INC ) + HOV_INC(Ares, k) + else + FOR_0_LE_i_LT_k + ARES_INC *= coval; + + get_taylors(res,k); + break; + +/*--------------------------------------------------------------------------*/ + case eq_mult_a: /* Multiply one adouble by another eq_mult_a */ + /* (*=) */ + res = get_locint_r(); + arg = get_locint_r(); + + get_taylors(res,k); + + ASSIGN_A(Ares, A[res]) + ASSIGN_A(Aarg, A[arg]) + ASSIGN_A(Aqo, Atemp) + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ, T[arg]) + + FOR_0_LE_l_LT_p + { if (0 == ARES) + { HOV_INC(Aarg, k1) + HOV_INC(Ares, k1) + } + else + { MAXINC(ARES,2.0); + MAXINC(AARG,ARES); + AARG_INC_O; ARES_INC_O; + conv(k,Ares,Targ,Atemp); + if(arg != res) + { inconv(k,Ares,Tres,Aarg); + FOR_0_LE_i_LT_k + ARES_INC = AQO_INC; + } + else + FOR_0_LE_i_LT_k + ARES_INC = 2.0 * AQO_INC; + HOV_INC(Aarg,k) + } + } + break; + +/*--------------------------------------------------------------------------*/ + case incr_a: /* Increment an adouble incr_a */ + case decr_a: /* Increment an adouble decr_a */ + res = get_locint_r(); + + get_taylors(res,k); + break; + + +/****************************************************************************/ +/* BINARY OPERATIONS */ + +/*--------------------------------------------------------------------------*/ + case plus_a_a: /* : Add two adoubles. (+) plus a_a */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + ASSIGN_A(Ares, A[res]) + ASSIGN_A(Aarg1, A[arg1]) + ASSIGN_A(Aarg2, A[arg2]) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg1, k1) + HOV_INC(Aarg2, k1) + } + else + { aTmp = ARES; + ARES_INC = 0.0; + MAXINC(AARG1,aTmp); + MAXINC(AARG2,aTmp); + AARG2_INC_O; AARG1_INC_O; + FOR_0_LE_i_LT_k + { aTmp = ARES; + ARES_INC = 0.0; + AARG1_INC += aTmp; + AARG2_INC += aTmp; + } + } + + get_taylors(res,k); + break; + +/*--------------------------------------------------------------------------*/ + case plus_d_a: /* Add an adouble and a double plus_d_a */ + /* (+) */ + res = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + ASSIGN_A(Ares, A[res]) + ASSIGN_A(Aarg, A[arg]) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg, k1) + } + else + { aTmp = ARES; + ARES_INC = 0.0; + MAXINC(AARG,aTmp); + AARG_INC_O; + FOR_0_LE_i_LT_k + { aTmp = ARES; + ARES_INC = 0.0; + AARG_INC += aTmp; + } + } + + get_taylors(res,k); + break; + +/*--------------------------------------------------------------------------*/ + case min_a_a: /* Subtraction of two adoubles min_a_a */ + /* (-) */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + ASSIGN_A(Ares, A[res]) + ASSIGN_A(Aarg1, A[arg1]) + ASSIGN_A(Aarg2, A[arg2]) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg1, k1) + HOV_INC(Aarg2, k1) + } + else + { aTmp = ARES; + ARES_INC = 0.0; + MAXINC(AARG1,aTmp); + MAXINC(AARG2,aTmp); + AARG2_INC_O; AARG1_INC_O; + FOR_0_LE_i_LT_k + { aTmp = ARES; + ARES_INC = 0.0; + AARG1_INC += aTmp; + AARG2_INC -= aTmp; + } + } + + get_taylors(res,k); + break; + +/*--------------------------------------------------------------------------*/ + case min_d_a: /* Subtract an adouble from a min_d_a */ + /* double (-) */ + res = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + ASSIGN_A(Ares, A[res]) + ASSIGN_A(Aarg, A[arg]) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg, k1) + } + else + { aTmp = ARES; + ARES_INC = 0.0; + MAXINC(AARG,aTmp); + AARG_INC_O; + FOR_0_LE_i_LT_k + { aTmp = ARES; + ARES_INC = 0.0; + AARG_INC -= aTmp; + } + } + + get_taylors(res,k); + break; + +/*--------------------------------------------------------------------------*/ + case mult_a_a: /* Multiply two adoubles (*) mult_a_a */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + get_taylors(res,k); + + ASSIGN_A(Ares, A[res]) + ASSIGN_A(Aarg2, A[arg2]) + ASSIGN_A(Aarg1, A[arg1]) + ASSIGN_T(Targ1, T[arg1]) + ASSIGN_T(Targ2, T[arg2]) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Aarg1, k1) + HOV_INC(Aarg2, k1) + HOV_INC(Ares, k1) + } + else + { comp = (ARES > 2.0) ? ARES : 2.0 ; + ARES_INC = 0.0; + MAXINC(AARG1,comp); + MAXINC(AARG2,comp); + AARG1_INC_O; AARG2_INC_O; + + copyAndZeroset(k,Ares,Atemp); + inconv(k,Atemp,Targ1,Aarg2); + inconv(k,Atemp,Targ2,Aarg1); + + HOV_INC(Ares, k) + HOV_INC(Aarg1, k) + HOV_INC(Aarg2, k) + } + break; + +/*--------------------------------------------------------------------------*/ + /* olvo 991122: new op_code with recomputation */ + case eq_plus_prod: /* increment a product of eq_plus_prod */ + /* two adoubles (*) */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + + ASSIGN_A(Ares, A[res]) + ASSIGN_A(Aarg2, A[arg2]) + ASSIGN_A(Aarg1, A[arg1]) + ASSIGN_T(Targ1, T[arg1]) + ASSIGN_T(Targ2, T[arg2]) + + /* RECOMPUTATION */ + ASSIGN_T( Tres, T[res]) + deconv(k,Targ1,Targ2,Tres); + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Aarg1, k1) + HOV_INC(Aarg2, k1) + HOV_INC(Ares, k1) + } + else + { comp = (ARES > 2.0) ? ARES : 2.0 ; + ARES_INC = comp; + MAXINC(AARG1,comp); + MAXINC(AARG2,comp); + AARG1_INC_O; AARG2_INC_O; + + inconv(k,Ares,Targ1,Aarg2); + inconv(k,Ares,Targ2,Aarg1); + + HOV_INC(Ares, k) + HOV_INC(Aarg1, k) + HOV_INC(Aarg2, k) + } + break; + +/*--------------------------------------------------------------------------*/ + /* olvo 991122: new op_code with recomputation */ + case eq_min_prod: /* decrement a product of eq_min_prod */ + /* two adoubles (*) */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + + ASSIGN_A(Ares, A[res]) + ASSIGN_A(Aarg2, A[arg2]) + ASSIGN_A(Aarg1, A[arg1]) + ASSIGN_T(Targ1, T[arg1]) + ASSIGN_T(Targ2, T[arg2]) + + /* RECOMPUTATION */ + ASSIGN_T( Tres, T[res]) + inconv(k,Targ1,Targ2,Tres); + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Aarg1, k1) + HOV_INC(Aarg2, k1) + HOV_INC(Ares, k1) + } + else + { comp = (ARES > 2.0) ? ARES : 2.0 ; + ARES_INC = comp; + MAXINC(AARG1,comp); + MAXINC(AARG2,comp); + AARG1_INC_O; AARG2_INC_O; + + deconv(k,Ares,Targ1,Aarg2); + deconv(k,Ares,Targ2,Aarg1); + + HOV_INC(Ares, k) + HOV_INC(Aarg1, k) + HOV_INC(Aarg2, k) + } + break; + +/*--------------------------------------------------------------------------*/ + case mult_d_a: /* Multiply an adouble by a double mult_d_a */ + /* (*) */ + res = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + ASSIGN_A(Ares, A[res]) + ASSIGN_A(Aarg, A[arg]) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg, k1) + } + else + { aTmp = ARES; + ARES_INC = 0.0; + MAXINC(AARG,aTmp); + AARG_INC_O; + FOR_0_LE_i_LT_k + { aTmp = ARES; + ARES_INC = 0.0; + AARG_INC += coval * aTmp; + } + } + + get_taylors(res,k); + break; + +/*--------------------------------------------------------------------------*/ + case div_a_a: /* Divide an adouble by an adouble div_a_a */ + /* (/) */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + ASSIGN_A(Ares, A[res]) + ASSIGN_A(Aarg2, A[arg2]) + ASSIGN_A(Aarg1, A[arg1]) + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ2, T[arg2]) + + /* olvo 980922 allows reflexive operation */ + if (arg2 == res) + { for (i=0; i Targ2[0]) + { FOR_0_LE_l_LT_p + { if ((coval) && (*AP2)) + MINDEC(ret_c,2); + HOV_INC(AP2,k1) + } + AP1 = Aarg2; + arg = 0; + } + else + if (Targ1[0] < Targ2[0]) + { FOR_0_LE_l_LT_p + { if ((!coval) && (*AP2)) + MINDEC(ret_c,2); + HOV_INC(AP2,k1) + } + AP1 = Aarg1; + arg = 0; + } + else /* both are equal */ + for (i=1;i Targ2[i]) + { FOR_0_LE_l_LT_p + { if (*AP2) + MINDEC(ret_c,1); + HOV_INC(AP2,k1) + } + AP1 = Aarg2; + arg = i+1; + } + else + if (Targ1[i] < Targ2[i]) + { FOR_0_LE_l_LT_p + { if (*AP2) + MINDEC(ret_c,1); + HOV_INC(AP2,k1) + } + AP1 = Aarg1; + arg = i+1; + } + if (AP1 != NULL) + break; + } + + if (AP1 != NULL) + FOR_0_LE_l_LT_p + { if (0 == ARES) + { HOV_INC(AP1, k1) + HOV_INC(Ares,k1); + } + else + { aTmp = ARES; + ARES_INC = 0.0; + if (arg) /* we are at the tie */ + *AP1 = 5.0; + else + MAXINC(*AP1,aTmp); + AP1++; + for (i=0;i0) && (aTmp)) + MINDEC(ret_c,2); + AARG_INC += x * aTmp; + } + } + break; + +/*--------------------------------------------------------------------------*/ + case ceil_op: /* ceil_op */ + res = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + get_taylors(res,k); + + coval = (coval != ceil(*T[arg]) ); + + ASSIGN_A(Ares, A[res]) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Aarg, k1) + HOV_INC(Ares, k1) + } + else + { ARES_INC = 0.0; AARG_INC = 5.0; + FOR_0_LE_i_LT_k + { if ((coval) && (ARES)) + MINDEC(ret_c,2); + ARES_INC = 0.0; + } + HOV_INC(Aarg, k) + } + break; + +/*--------------------------------------------------------------------------*/ + case floor_op: /* floor_op */ + res = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + get_taylors(res,k); + + coval = ( coval != floor(*T[arg]) ); + + ASSIGN_A(Ares, A[res]) + ASSIGN_A(Aarg, A[arg]) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Aarg, k1) + HOV_INC(Ares, k1) + } + else + { ARES = 0.0; AARG_INC = 5.0; + FOR_0_LE_i_LT_k + { if ( (coval) && (ARES) ) + MINDEC(ret_c,2); + ARES_INC = 0.0; + } + HOV_INC(Aarg, k) + } + break; + + +/****************************************************************************/ +/* CONDITIONALS */ + +/*--------------------------------------------------------------------------*/ + case cond_assign: /* cond_assign */ + res = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + get_taylors(res,k); + + ASSIGN_A(Aarg1, A[arg1]) + ASSIGN_A(Ares, A[res]) + ASSIGN_A(Aarg2, A[arg2]) + ASSIGN_T(Targ, T[arg]) + + /* olvo 980925 changed code a little bit */ + if (TARG > 0.0) + { if (res != arg1) + FOR_0_LE_l_LT_p + { if (0 == ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg1, k1) + } + else + { if (coval <= 0.0) + MINDEC(ret_c,2); + MAXINC(AARG1,ARES); + ARES_INC = 0.0; + AARG1_INC_O; + FOR_0_LE_i_LT_k + { AARG1_INC += ARES; + ARES_INC = 0; + } + } + } + else + FOR_0_LE_l_LT_p + { if ((coval <= 0.0) && (ARES)) + MINDEC(ret_c,2); + HOV_INC(Ares, k1) + } + } + else /* TARG <= 0.0 */ + { if (res != arg2) + FOR_0_LE_l_LT_p + { if (0 == ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg2, k1) + } + else + { if (TARG == 0.0) /* we are at the tie */ + { MINDEC(ret_c,0); + AARG1 = 5.0; AARG2_INC = 5.0; + } + else + { if (coval <= 0.0) + MINDEC(ret_c,2); + MAXINC(AARG2,ARES); + AARG2_INC_O; + } + ARES_INC = 0.0; + + FOR_0_LE_i_LT_k + { AARG2_INC += ARES; + ARES_INC = 0; + } + } + HOV_INC(Aarg1, k1) + } + else + FOR_0_LE_l_LT_p + { if (ARES) + { if (TARG == 0.0) /* we are at the tie */ + { MINDEC(ret_c,0); + AARG1 = 5.0; AARG2 = 5.0; + } + else + if (coval <= 0.0) + MINDEC(ret_c,2); + } + HOV_INC(Ares, k1) + HOV_INC(Aarg1, k1) + HOV_INC(Aarg2, k1) + } + } + break; + +/*--------------------------------------------------------------------------*/ + case cond_assign_s: /* cond_assign_s */ + res = get_locint_r(); + arg1 = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + get_taylors(res,k); + + ASSIGN_A(Aarg1, A[arg1]) + ASSIGN_A(Ares, A[res]) + ASSIGN_T(Targ, T[arg]) + + /* olvo 980925 changed code a little bit */ + if (TARG == 0.0) /* we are at the tie */ + { FOR_0_LE_l_LT_p + { if (ARES) + AARG1 = 5.0; + HOV_INC(Aarg1, k1) + HOV_INC(Ares, k1) + } + MINDEC(ret_c,0); + } + else + if (TARG > 0.0) + { if (res != arg1) + FOR_0_LE_l_LT_p + { if (0 == ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg1, k1) + } + else + { if (coval <= 0.0) + MINDEC(ret_c,2); + MAXINC(AARG1,ARES); + ARES_INC = 0.0; + AARG1_INC_O; + FOR_0_LE_i_LT_k + { (AARG1_INC) += ARES; + ARES_INC = 0; + } + } + } + else + FOR_0_LE_l_LT_p + { if ((coval <= 0.0) && (ARES)) + MINDEC(ret_c,2); + HOV_INC(Ares, k1) + } + } + break; + + +/****************************************************************************/ +/* VECTOR ASSIGNMENTS */ + +/*--------------------------------------------------------------------------*/ + case assign_av: /* assign_av */ + res = get_locint_r(); + size = get_locint_r(); + arg = get_locint_r(); + + res += size; + arg += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of left-hand-side */ + arg--; /* Location of right-hand-side */ + + /* code for assign_a */ + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Aarg, k1) + HOV_INC(Ares, k1) + } + else + { MAXINC(AARG,ARES); + AARG_INC_O; ARES_INC = 0.0; + FOR_0_LE_i_LT_k + { /* ! no tempory */ + AARG_INC += ARES; + ARES_INC = 0.0; + } + } + + get_taylors(res,k); + } + break; + +/*--------------------------------------------------------------------------*/ + case assign_dv: /* assign_dv */ + res = get_locint_r(); + size = get_locint_r(); + d = get_val_v_r(size); + + res += size; + d += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of left-hand-side */ + coval = *(--d); /* Value of right-hand-side */ + + /* code for assign_d */ + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_pk1 + ARES_INC = 0.0; + + get_taylors(res,k); + } + break; + +/*--------------------------------------------------------------------------*/ + case assign_indvec: /* assign_indvec */ + res = get_locint_r(); + size = get_locint_r(); + + res += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of the left-hand-side */ + + /* code for assign_ind */ + ASSIGN_A(Ares, A[res]) + + FOR_0_LE_l_LT_p + { +#ifdef _HOV_ + if (nonzero) /* ??? question: why here? */ + nonzero[l][indexi] = (int)ARES; +#endif /* _HOV_ */ + ARES_INC_O; + FOR_0_LE_i_LT_k + RESULTS(l,indexi,i) = ARES_INC; + } + + get_taylors(res,k); + indexi--; + } + reset_val_r(); + break; + +/*--------------------------------------------------------------------------*/ + case assign_depvec: /* assign_depvec */ + res = get_locint_r(); + size = get_locint_r(); + + res += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of the left-hand-side */ + + /* code for assign_dep */ + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + { *(++Ares) = LAGRANGE(l,indexd); + + if (ARES) + *(--Ares) = 1.0; + else + --Ares; + Ares += k1; + } + indexd--; + } + break; + + +/****************************************************************************/ +/* VECTOR OPERATION + ASSIGNMENT */ + +/*--------------------------------------------------------------------------*/ + case eq_plus_av: /* eq_plus_av */ + res = get_locint_r(); + size = get_locint_r(); + arg = get_locint_r(); + + res += size; + arg += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of left-hand-side */ + arg--; /* Location on right-hand-side */ + + /* code for eq_plus_a */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg, k1) + } + else + { MAXINC(AARG,ARES); + AARG_INC_O; ARES_INC_O; + FOR_0_LE_i_LT_k + AARG_INC += ARES_INC; + } + + get_taylors(res,k); + } + break; + +/*--------------------------------------------------------------------------*/ + case eq_min_av: /* eq_min_av */ + res = get_locint_r(); + size = get_locint_r(); + arg = get_locint_r(); + + res += size; + arg += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of left-hand-side */ + arg--; /* Location on right-hand-side */ + + /* code for eq_min_a */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + if (0==ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg, k1) + } + else + { MAXINC(AARG,ARES); + AARG_INC_O; ARES_INC_O; + FOR_0_LE_i_LT_k + AARG_INC -= ARES_INC; + } + + get_taylors(res,k); + } + break; + +/*--------------------------------------------------------------------------*/ + case eq_mult_av_d: /* eq_mult_av_d */ + res = get_locint_r(); + size = get_locint_r(); + coval = get_val_r(); + + res += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of the left-hand-side */ + /* coval = fixed; value on the right-hand-side */ + + /* code for eq_mult_d*/ + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + if ( 0 == ARES_INC ) + HOV_INC(Ares, k) + else + FOR_0_LE_i_LT_k + ARES_INC *= coval; + + get_taylors(res,k); + } + break; + +/*--------------------------------------------------------------------------*/ + case eq_mult_av_a: /* eq_mult_av_a */ + res = get_locint_r(); + size = get_locint_r(); + arg = get_locint_r(); + + /* olvo 980929 new strategy to check for overwrites + (changes computation order) */ + if ((arg >= res) && (arg < res+size)) + { /* FIRST compute the case: res==arg */ + /* simplified code for eq_mult_a*/ + get_taylors(arg,k); + + ASSIGN_T( Targ, T[arg]) + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Aqo, Atemp) + + FOR_0_LE_l_LT_p + if (0 == AARG) + { HOV_INC(Aarg, k1) + } + else + { MAXINC(AARG,2.0); + AARG_INC_O; + conv(k,Aarg,Targ,Atemp); + FOR_0_LE_i_LT_k + AARG_INC = 2.0 * AQO_INC; + } + } + + res += size; + for (ls=size; ls>0; ls--) + { res--; /* Location of the left-hand-side */ + /* arg = fixed; Location on the right-hand-side */ + + if (res == arg) /* NOW skip this case */ + continue; + + /* code for eq_mult_a*/ + get_taylors(res,k); + + ASSIGN_T( Tres, T[res]) + ASSIGN_T( Targ, T[arg]); + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aqo, Atemp) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Aarg, k1) + HOV_INC(Ares, k1) + } + else + { MAXINC(ARES,2.0); + MAXINC(AARG,ARES); + AARG_INC_O; ARES_INC_O; + conv(k,Ares,Targ,Atemp); + if(arg != res) + { inconv(k,Ares,Tres,Aarg); + FOR_0_LE_i_LT_k + ARES_INC = AQO_INC; + } + else + FOR_0_LE_i_LT_k + ARES_INC = 2.0 * AQO_INC; + HOV_INC(Aarg, k) + } + } + break; + + +/****************************************************************************/ +/* BINARY VECTOR OPERATIONS */ + +/*--------------------------------------------------------------------------*/ + case plus_av_av: /* plus_av_av */ + res = get_locint_r(); + size = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + res += size; + arg1 += size; + arg2 += size; + for (ls=size; ls>0; ls--) + { arg2--; /* Location of var 2 */ + arg1--; /* Location of var 1 */ + res--; /* Location of result */ + + /* code for plus_a_a */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_A( Aarg2, A[arg2]) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg1, k1) + HOV_INC(Aarg2, k1) + } + else + { aTmp = ARES; + ARES_INC = 0.0; + MAXINC(AARG1,aTmp); + MAXINC(AARG2,aTmp); + AARG2_INC_O; AARG1_INC_O; + FOR_0_LE_i_LT_k + { aTmp = ARES; + ARES_INC = 0.0; + AARG1_INC += aTmp; + AARG2_INC += aTmp; + } + } + + get_taylors(res,k); + } + break; + +/*--------------------------------------------------------------------------*/ + case sub_av_av: /* sub_av_av */ + res = get_locint_r(); + size = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + res += size; + arg1 += size; + arg2 += size; + for (ls=size; ls>0; ls--) + { arg2--; /* Location of var 2 */ + arg1--; /* Location of var 1 */ + res--; /* Location of result */ + + /* code for min_a_a */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_A( Aarg2, A[arg2]) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg1, k1) + HOV_INC(Aarg2, k1) + } + else + { aTmp = ARES; + ARES_INC = 0.0; + MAXINC(AARG1,aTmp); + MAXINC(AARG2,aTmp); + AARG2_INC_O; AARG1_INC_O; + FOR_0_LE_i_LT_k + { aTmp = ARES; + ARES_INC = 0.0; + AARG1_INC += aTmp; + AARG2_INC -= aTmp; + } + } + get_taylors(res,k); + } + break; + +/*--------------------------------------------------------------------------*/ + case dot_av_av: /* dot_av_av */ + res = get_locint_r(); + size = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + get_taylors(res,k); + + /* save Ares to Atemp */ + ASSIGN_A( Aqo, Atemp) + ASSIGN_A( Ares, A[res]) + FOR_0_LE_l_LT_pk1 + { AQO_INC = ARES; + ARES_INC = 0.0; + } + + for (ls=0; ls 2.0) ? AQO : 2.0 ; + MAXINC(AARG1,comp); + MAXINC(AARG2,comp); + AARG1_INC_O; AARG2_INC_O; AQO_INC_O; + + inconv(k,Aqo,Targ1,Aarg2); + inconv(k,Aqo,Targ2,Aarg1); + + HOV_INC(Aqo, k) + HOV_INC(Aarg1, k) + HOV_INC(Aarg2, k) + } + arg1++; arg2++; + } + break; + +/*--------------------------------------------------------------------------*/ + case mult_a_av: /* mult_a_av */ + res = get_locint_r(); + size = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + /* olvo 980929 new strategy to check for overwrites + (changes computation order) */ + if ((arg2 >= res) && (arg2 < res+size)) + { /* FIRST compute the case: res==arg2 */ + /* simplified code for mult_a_a */ + get_taylors(arg2,k); + + ASSIGN_A( Aarg1, A[arg1+res-arg2]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_T( Targ2, T[arg2]) + ASSIGN_T( Targ1, T[arg1+res-arg2]) + + FOR_0_LE_l_LT_p + if (0 == AARG2) + { HOV_INC(Aarg1, k1) + HOV_INC(Aarg2, k1) + } + else + { MAXINC(AARG1,AARG2); + AARG1_INC_O; AARG2_INC_O; + + copyAndZeroset(k,Aarg2,Atemp); + inconv(k,Atemp,Targ1,Aarg2); + inconv(k,Atemp,Targ2,Aarg1); + + HOV_INC(Aarg1, k) + HOV_INC(Aarg2, k) + } + } + + res += size; + arg1 += size; + for (ls=size; ls>0; ls--) + { arg1--; /* Location of rght hnd side vectore[l] */ + res--; /* Location of the result */ + + if (res == arg2) /* NOW skip this case */ + continue; + + /* code for mult_a_a */ + get_taylors(res,k); + + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_T( Targ2, T[arg2]) + ASSIGN_T( Targ1, T[arg1]) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Aarg1, k1) + HOV_INC(Aarg2, k1) + HOV_INC(Ares, k1) + } + else + { comp = (ARES > 2.0) ? ARES : 2.0 ; + ARES_INC = 0.0; + MAXINC(AARG1,comp); + MAXINC(AARG2,comp); + AARG1_INC_O; AARG2_INC_O; + + copyAndZeroset(k,Ares,Atemp); + inconv(k,Atemp,Targ1,Aarg2); + inconv(k,Atemp,Targ2,Aarg1); + + HOV_INC(Ares, k) + HOV_INC(Aarg1, k) + HOV_INC(Aarg2, k) + } + } + break; + +/*--------------------------------------------------------------------------*/ + case mult_d_av: /* mult_d_av */ + res = get_locint_r(); + size = get_locint_r(); + arg = get_locint_r(); + coval = get_val_r(); + + res += size; + arg += size; + for (ls=size; ls>0; ls--) + { arg--; /* Location on the right-hand-side */ + res--; /* location of the result */ + /* coval = Fixed double value */ + + /* code for mult_d_a */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg, A[arg]) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg, k1) + } + else + { aTmp = ARES; + ARES_INC = 0.0; + MAXINC(AARG,aTmp); + AARG_INC_O; + FOR_0_LE_i_LT_k + { aTmp = ARES; + ARES_INC = 0.0; + AARG_INC += coval * aTmp; + } + } + + get_taylors(res,k); + } + break; + +/*--------------------------------------------------------------------------*/ + case div_av_a: /* div_av_a */ + res = get_locint_r(); + size = get_locint_r(); + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + /* olvo 980929 new strategy to check for overwrites + (changes computation order) */ + if ((arg2 >= res) && (arg2 < res+size)) + { /* FIRST compute the case: res==arg2 */ + /* simplified code for div_a_a */ + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Aarg1, A[arg1+res-arg2]) + ASSIGN_T( Targ2, T[arg2]) + + for (i=0; i0; ls--) + { arg1--; /* Location of right-hand-side vector[l] */ + res--; /* Location of the result */ + + if (res == arg2) /* NOW skip this case */ + continue; + + /* code for div_a_a */ + ASSIGN_A( Ares, A[res]) + ASSIGN_A( Aarg2, A[arg2]) + ASSIGN_A( Aarg1, A[arg1]) + ASSIGN_T( Tres, T[res]) + ASSIGN_T( Targ2, T[arg2]) + +VEC_COMPUTED_INIT + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg1, k1) + HOV_INC(Aarg2, k1) + } + else + { aTmp = ARES; + ARES_INC = 0.0; + MAXINC(AARG1,3.0); + MAXINC(AARG1,aTmp); + MAXINC(AARG2,3.0); + MAXINC(AARG2,aTmp); + AARG1_INC_O; AARG2_INC_O; + +VEC_COMPUTED_CHECK + recipr(k,1.0,Targ2,Ttemp); + conv(k,Ttemp,Tres,Atemp2); +VEC_COMPUTED_END + copyAndZeroset(k,Ares,Atemp); + inconv(k,Atemp,Ttemp,Aarg1); + deconv(k,Atemp,Atemp2,Aarg2); + + HOV_INC(Ares, k) + HOV_INC(Aarg1, k) + HOV_INC(Aarg2, k) + } + + get_taylors(res,k); + } + break; + + +/****************************************************************************/ +/* SUBSCRIPTS */ + +/*--------------------------------------------------------------------------*/ + case subscript: /* subscript */ + res = get_locint_r(); + arg1 = get_locint_r(); + arg2 = get_locint_r(); + coval = get_val_r(); + + arg = arg2 + (int)(T[arg1][0]); + + /* olvo 980721 new nl */ + get_taylors(res,k); + + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg, k1) + } + else + { if ((int)(coval) != (int)(T[arg1][0])) + MINDEC(ret_c,2); + aTmp = ARES; + ARES_INC = 0.0; + MAXINC(AARG,aTmp); + AARG_INC_O; + + FOR_0_LE_i_LT_k + { AARG_INC += ARES; + if (arg != res) + ARES_INC = 0; + else + ARES_INC_O; + } + } + break; + +/*--------------------------------------------------------------------------*/ + case subscript_l: /* subscript_l */ + arg = get_locint_r(); + arg1 = get_locint_r(); + arg2 = get_locint_r(); + coval = get_val_r(); + + res = arg2 + (int)(T[arg1][0]); + + get_taylors(res,k); + + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + if (0==ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg, k1) + } + else + { if ((int)(coval) != (int)(T[arg1][0])) + MINDEC(ret_c,2); + aTmp = ARES; + ARES_INC = 0.0; + MAXINC(AARG,aTmp); + AARG_INC_O; + + FOR_0_LE_i_LT_k + { AARG_INC += ARES; + if (res != arg) + ARES_INC = 0; + else + ARES_INC_O; + } + } + break; + +/*--------------------------------------------------------------------------*/ + case subscript_ld: /* subscript_ld */ + arg1 = get_locint_r(); + arg2 = get_locint_r(); + coval = get_val_r(); + coval = get_val_r(); + + arg = arg2 + (int)(T[arg1][0]); + + get_taylors(arg,k); + + if((int)(coval)!=(int)(T[arg1][0])) + MINDEC(ret_c,2); + + ASSIGN_A( Aarg, A[arg]); + + FOR_0_LE_l_LT_pk1 + AARG_INC = 0.0; + + break; + +/*--------------------------------------------------------------------------*/ + case m_subscript: /* m_subscript */ + res = get_locint_r(); + size = get_locint_r(); + arg1 = get_locint_r(); + arg2 = get_locint_r(); + coval = get_val_r(); + + res += size; + arg = arg2 + ((int)(T[arg1][0]) + 1)*size; + for (ls=size; ls>0; ls--) + { res--; arg--; + + /* olvo 980721 new nl */ + get_taylors(res,k); + + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg, k1) + } + else + { if ((int)(coval)!=(int)(T[arg1][0])) + MINDEC(ret_c,2); + aTmp = ARES; + ARES_INC = 0.0; + MAXINC(AARG,aTmp); + AARG_INC_O; + + FOR_0_LE_i_LT_k + { AARG_INC += ARES; + if (arg != res) + ARES_INC = 0; + else + ARES_INC_O; + } + } + } + break; + +/*--------------------------------------------------------------------------*/ + case m_subscript_l: /* m_subscript_l */ + arg = get_locint_r(); + size = get_locint_r(); + arg1 = get_locint_r(); + arg2 = get_locint_r(); + coval = get_val_r(); + + res = arg2 + ((int)(T[arg1][0]) + 1)*size; + arg += size; + for (ls=size; ls>0; ls--) + { arg--; res--; + + get_taylors(res,k); + + ASSIGN_A( Aarg, A[arg]) + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_p + if (0 == ARES) + { HOV_INC(Ares, k1) + HOV_INC(Aarg, k1) + } + else + { if ((int)(coval)!=(int)(T[arg1][0])) + MINDEC(ret_c,2); + aTmp = ARES; + ARES_INC = 0.0; + MAXINC(AARG,aTmp); + AARG_INC_O; + + FOR_0_LE_i_LT_k + { AARG_INC += ARES; + if (arg != res) + ARES_INC = 0; + else + ARES_INC; + } + } + } + break; + +/*--------------------------------------------------------------------------*/ + case m_subscript_ld: /* m_subscript_ld */ + size = get_locint_r(); + arg = get_locint_r(); + arg1 = get_locint_r(); + arg2 = get_locint_r(); + /* olvo 980702 changed n2l */ + d = get_val_v_r(size); + coval = get_val_r(); + + if ((int)(coval) != (int)(T[arg1][0])) + MINDEC(ret_c,2); + + res = arg2 + ((int)(T[arg1][0]) + 1)*size + arg; + for (ls=size; ls>0; ls--) + { res--; + + get_taylors(res,k); + + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_pk1 + ARES_INC = 0.0; + } + break; + + +/****************************************************************************/ +/* REMAINING STUFF */ + +/*--------------------------------------------------------------------------*/ + case take_stock_op: /* take_stock_op */ + res = get_locint_r(); + size = get_locint_r(); + d = get_val_v_r(size); + + res += size; + for (ls=size;ls>0;ls--) + { res--; + + ASSIGN_A( Ares, A[res]) + + FOR_0_LE_l_LT_pk1 + ARES_INC = 0.0; + } +#ifdef _HOV_ + /* olvo 980804 necessary or not?: reset_val_r(); */ + /* olvo 980623 ??? why that ? */ +#endif + break; + +/*--------------------------------------------------------------------------*/ + case death_not: /* death_not */ + arg2 = get_locint_r(); + arg1 = get_locint_r(); + + for (j=arg1;j<=arg2;j++) + { ASSIGN_A(Aarg1, A[j]) + + FOR_0_LE_l_LT_p + for (i=0; i uni5_for.c for + zos_forward.c (zos_forward) + fos_forward.c (fos_forward) + hos_forward.c (hos_forward) + fov_forward.c (fov_forward) + hov_forward.c (hov_forward) + fo_rev.c for + fos_reverse.c (fos_reverse) + fov_reverse.c (fov_reverse) + ho_rev.c for + hos_reverse.c (hos_reverse) + hov_reverse.c (hov_reverse) + interfacesC.C + interfacesf.c + + ADOL-C Abreviations : + zos : zero-order-scalar mode + fos : first-order-scalar mode + hos : higher-order-scalar mode + fov : first-order-vector mode + hov : higher-order-vector mode + + Last changes: + 981201 olvo: automatic include of "SPARSE/sparse.h" + 981130 olvo: newly created by unification of ADOLC-kernel + routines of adutils?.h + + History of adutils.h: + 981126 olvo last check (p's & q's) + 980727 olvo ec U[m][p] ---> U[p][m] + + History of adutilsc.h: + 981126 olvo: last check + + -------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/****************************************************************************/ +/****************************************************************************/ +/* PUBLIC EXPORTS ONLY */ +#include "usrparms.h" + +#ifdef __cplusplus +/****************************************************************************/ +/****************************************************************************/ +/* Now the C++ THINGS */ + +/****************************************************************************/ +/* FORWARD MODE, overloaded calls */ + +/*--------------------------------------------------------------------------*/ +/* General scalar call. For d=0 or d=1 done by specialized code */ +/* */ +/* forward(tag, m, n, d, keep, X[n][d+1], Y[m][d+1]) : hos || fos || zos */ + +int forward(short, int, int, int, int, double**, double**); + +/*--------------------------------------------------------------------------*/ +/* Y can be one dimensional if m=1. d=0 or d=1 done by specialized code */ +/* */ +/* forward(tag, m, n, d, keep, X[n][d+1], Y[d+1]) : hos || fos || zos */ + +int forward(short, int, int, int, int, double**, double*); + +/*--------------------------------------------------------------------------*/ +/* X and Y can be one dimensional if d = 0; done by specialized code */ +/* */ +/* forward(tag, m, n, d, keep, X[n], Y[m]) : zos */ + +int forward(short, int, int, int, int, double*, double*); + +/*--------------------------------------------------------------------------*/ +/* X and Y can be one dimensional if d omitted; done by specialized code */ +/* */ +/* forward(tag, m, n, keep, X[n], Y[m]) : zos */ + +int forward(short, int, int, int, double*, double*); + +/*--------------------------------------------------------------------------*/ +/* General vector call */ +/* */ +/* forward(tag, m, n, d, p, x[n], X[n][p][d], y[m], Y[m][p][d]) : hov */ + +int forward(short, int, int, int, int, double*, double***, + double*, double***); + +/*--------------------------------------------------------------------------*/ +/* d = 1 may be omitted. General vector call, done by specialized code */ +/* */ +/* forward(tag, m, n, p, x[n], X[n][p], y[m], Y[m][p]) : fov */ + +int forward(short, int, int, int, double*, double**, double*, double**); + + +/****************************************************************************/ +/* REVERSE MODE, overloaded calls */ + +/*--------------------------------------------------------------------------*/ +/* General call */ +/* */ +/* reverse(tag, m, n, d, u[m], Z[n][d+1]) : hos */ + +int reverse(short, int, int, int, double*, double**); + +/*--------------------------------------------------------------------------*/ +/* u can be a scalar if m=1 */ +/* */ +/* reverse(tag, m, n, d, u, Z[n][d+1]) : hos */ + +int reverse(short, int, int, int, double, double**); + +/*--------------------------------------------------------------------------*/ +/* Z can be vector if d = 0; done by specialized code */ +/* */ +/* reverse(tag, m, n, d, u[m], Z[n]) : fos */ + +int reverse(short, int, int, int, double*, double*); + +/*--------------------------------------------------------------------------*/ +/* u can be a scalar if m=1 and d=0; done by specialized code */ +/* */ +/* reverse(tag, m, n, d, u, Z[n]) : fos */ + +int reverse(short, int, int, int, double, double*); + +/*--------------------------------------------------------------------------*/ +/* General vector call */ +/* */ +/* reverse(tag, m, n, d, q, U[q][m], Z[q][n][d+1], nz[q][n]) : hov */ + +int reverse(short, int, int, int, int, double**, double***, short** =0); + +/*--------------------------------------------------------------------------*/ +/* U can be a vector if m=1 */ +/* */ +/* reverse(tag, m, n, d, q, U[q], Z[q][n][d+1], nz[q][n]) : hov */ + +int reverse(short, int, int, int, int, double*, double***, short** = 0); + +/*--------------------------------------------------------------------------*/ +/* */ +/* If d=0 then Z may be a matrix, no nz; done by specialized cod */ +/* */ +/* reverse(tag, m, n, d, q, U[q][m], Z[q][n]) : fov */ + +int reverse(short, int, int, int, int, double**, double**); + +/*--------------------------------------------------------------------------*/ +/* */ +/* d=0 may be omitted, Z is a matrix, no nz; done by specialized code */ +/* */ +/* reverse(tag, m, n, q, U[q][m], Z[q][n]) : fov */ + +int reverse(short, int, int, int, double**, double**); + +/*--------------------------------------------------------------------------*/ +/* */ +/* If m=1 and d=0 then U can be vector and Z a matrix but no nz. */ +/* Done by specialized code */ +/* */ +/* reverse(tag, m, n, d, q, U[q], Z[q][n]) : fov */ + +int reverse(short, int, int, int, int, double*, double**); + +/*--------------------------------------------------------------------------*/ +/* */ +/* If q and U are omitted they default to m and I so that as above */ +/* */ +/* reverse(tag, m, n, d, Z[q][n][d+1], nz[q][n]) : hov */ + +int reverse(short, int, int, int, double***, short** =0); + + +/****************************************************************************/ +/****************************************************************************/ +/* Now the C THINGS */ +extern "C" { +#endif + +/****************************************************************************/ +/* FORWARD MODE */ + +/*--------------------------------------------------------------------------*/ +/* ZOS */ +/* zos_forward(tag, m, n, keep, x[n], y[m]) */ +/* (defined in uni5_for.c) */ + +int zos_forward(short,int,int,int,double*,double*); + +/* zos_forward_nk(tag, m, n, x[n], y[m]) */ +/* (no keep, defined in uni5_for.c, but not supported in ADOL-C 1.8) */ + +int zos_forward_nk(short,int,int,double*,double*); + + +/*--------------------------------------------------------------------------*/ +/* FOS */ +/* fos_forward(tag, m, n, keep, x[n], X[n], y[m], Y[m]) */ +/* (defined in uni5_for.c) */ + +int fos_forward(short,int,int,int,double*,double*,double*,double*); + +/* fos_forward_nk(tag,m,n,x[n],X[n],y[m],Y[m]) */ +/* (no keep, defined in uni5_for.c, but not supported in ADOL-C 1.8) */ + +int fos_forward_nk(short,int,int,double*,double*,double*,double*); + + +/*--------------------------------------------------------------------------*/ +/* HOS */ +/* hos_forward(tag, m, n, d, keep, x[n], X[n][d], y[m], Y[m][d]) */ +/* (defined in uni5_for.c) */ + +int hos_forward(short,int,int,int,int,double*,double**,double*,double**); + +/* hos_forward_nk(tag, m, n, d, x[n], X[n][d], y[m], Y[m][d]) */ +/* (no keep, defined in uni5_for.c, but not supported in ADOL-C 1.8) */ + +int hos_forward_nk(short,int,int,int,double*,double**,double*,double**); + +/* now pack the arrays into vectors for Fortran calling */ +fint hos_forward_(fint*,fint*,fint*,fint*,fint*,fdouble*,fdouble*, + fdouble*,fdouble*); + + +/*--------------------------------------------------------------------------*/ +/* FOV */ +/* fov_forward(tag, m, n, p, x[n], X[n][p], y[m], Y[m][p]) */ +/* (defined in uni5_for.c) */ + +int fov_forward(short, int,int,int,double*,double**,double*,double**); + +/* now pack the arrays into vectors for Fortran calling */ +fint fov_forward_(fint*,fint*,fint*,fint*,fdouble*,fdouble*, + fdouble*,fdouble*); + + +/*--------------------------------------------------------------------------*/ +/* HOV */ +/* hov_forward(tag, m, n, d, p, x[n], X[n][p][d], y[m], Y[m][p][d]) */ +/* (defined in uni5_for.c) */ + +int hov_forward(short,int,int,int,int,double*,double***,double*,double***); + +/* now pack the arrays into vectors for Fortran calling */ +fint hov_forward_(fint*,fint*,fint*,fint*,fint*,fdouble*,fdouble*, + fdouble*,fdouble*); + + + +/****************************************************************************/ +/* REVERSE MODE */ + +/*--------------------------------------------------------------------------*/ +/* FOS */ +/* fos_reverse(tag, m, n, u[m], z[n]) */ +/* (defined in fo_rev.c) */ + +int fos_reverse(short,int,int,double*,double*); + +/* now pack the arrays into vectors for Fortran calling */ +fint fos_reverse_(fint*,fint*,fint*,fdouble*,fdouble*); + + +/*--------------------------------------------------------------------------*/ +/* HOS */ +/* hos_reverse(tag, m, n, d, u[m], Z[n][d+1]) */ +/* (defined in ho_rev.c) */ + +int hos_reverse(short,int,int,int,double*,double**); + +/* now pack the arrays into vectors for Fortran calling */ +fint hos_reverse_(fint*,fint*,fint*,fint*,fdouble*,fdouble*); + + +/*--------------------------------------------------------------------------*/ +/* FOV */ +/* fov_reverse(tag, m, n, d, p, U[p][m], Z[p][n]) */ +/* (defined in fo_rev.c) */ + +int fov_reverse(short,int,int,int,double**,double**); + +/* now pack the arrays into vectors for Fortran calling */ +fint fov_reverse_(fint*,fint*,fint*,fint*,fdouble*,fdouble*); + + +/*--------------------------------------------------------------------------*/ +/* HOV */ +/* hov_reverse(tag, m, n, d, p, U[p][m], Z[p][n][d+1], nz[p][n]) */ +/* (defined in ho_rev.c) */ + +int hov_reverse(short,int,int,int,int,double**,double***,short**); + +/* now pack the arrays into vectors for Fortran calling */ +fint hov_reverse_(fint*,fint*,fint*,fint*,fint*,fdouble*,fdouble*); + + +/****************************************************************************/ +/* THAT'S ALL */ +#ifdef __cplusplus +} +#endif + +/*--------------------------------------------------------------------------*/ +/* Automatic include */ +#include "SPARSE/sparse.h" + +#endif diff --git a/adol-c/SRC/interfacesC.C b/adol-c/SRC/interfacesC.C new file mode 100644 index 0000000..a51fd32 --- /dev/null +++ b/adol-c/SRC/interfacesC.C @@ -0,0 +1,500 @@ +#define _INTERFACESC_CPP_ +#define _ADOLC_SRC_ +/* + ------------------------------------------------------------- + File interfacesC.C of ADOL-C version 1.8.4 as of Jul/15/99 + ------------------------------------------------------------- + Genuine C++ Interfaces to ADOL-C forward & reverse calls. + + Last changes: + 990715 olvo: performance tuning + 981201 olvo: newly created from interfaces.C + + History of interfaces.C: + 981126 olvo: last check (p's & q's) + 980818 olvo: new: double* myalloc(int) + 980731 olvo: debugging + 980729 olvo: bigger ec + 980727 olvo: ec in reverse U[m][p] ---> U[p][m] + + -------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/* INCLUDES */ +#include "dvlparms.h" +#include "usrparms.h" +#include "interfaces.h" +#include "adalloc.h" + +#include +#include +#include + + +/****************************************************************************/ +/* MACROS */ +#define fabs(x) ((x) > 0 ? (x) : -(x)) +#define ceil(x) ((int)((x)+1) - (int)((x) == (int)(x))) + + +/****************************************************************************/ +/* FORWARD MODE, overloaded calls */ + +/****************************************************************************/ +/* general call */ +/* */ +int forward( short tag, + int m, + int n, + int d, + int keep, + double **X, + double **Y) +/* forward(tag, m, n, d, keep, X[n][d+1], Y[m][d+1]) */ +{ /* olvo 980729 general ec */ + static double *x, *y, *xp, *yp; + static int maxn, maxm; + int rc = -1, i, k; + if (n > maxn) + { if (x) + myfree1(x); + if (xp) + myfree1(xp); + x = myalloc1(maxn = n); + xp = myalloc1(maxn); + } + if (m > maxm) + { if (y) + myfree1(y); + if (yp) + myfree1(yp); + y = myalloc1(maxm = m); + yp = myalloc1(maxm); + } + + /*------------------------------------------------------------------------*/ + /* prepare input */ + for (i=0; i 1) + { for (k=d; k>0; k--) + X[i][k] = X[i][k-1]; + X[i][0] = x[i]; + } + + for (i=0; i0; k--) + Y[i][k] = Y[i][k-1]; + Y[i][0] = y[i]; + } + + return rc; +} + + +/****************************************************************************/ +/* Y can be one dimensional if m=1 */ +/* */ +int forward( short tag, + int m, + int n, + int d, + int keep, + double **X, + double *Y) +/* forward(tag, 1, n, d, keep, X[n][d+1], Y[d+1]), m=1 */ +{ /* olvo 980729 general ec */ + static double *x, *xp; + static int maxn; + double y; + int rc= -1, i, k; + + if (m == 1) + { if (n > maxn) + { if (x) + myfree1(x); + if (xp) + myfree1(xp); + x = myalloc1(maxn = n); + xp = myalloc1(maxn); + } + + /*----------------------------------------------------------------------*/ + /* prepare input */ + for (i=0; i 1) + { for (k=d; k>0; k--) + X[i][k] = X[i][k-1]; + X[i][0] = x[i]; + } + + for (k=d; k>0; k--) + Y[k] = Y[k-1]; + Y[0] = y; + } + else + { fprintf(DIAG_OUT,"ADOL-C error: wrong Y dimension in forward \n"); + exit(-1); + } + + return rc; +} + + +/****************************************************************************/ +/* X and Y can be one dimensional if d = 0 */ +/* */ +int forward( short tag, + int m, + int n, + int d, + int keep, + double *X, + double *Y) +/* forward(tag, m, n, 0, keep, X[n], Y[m]), d=0 */ +{ int rc = -1; + + if (d != 0) + { fprintf(DIAG_OUT,"ADOL-C error: wrong X and Y dimensions in forward \n"); + exit(-1); + } + else + rc = zos_forward(tag,m,n,keep,X,Y); + + return rc; +} + + +/****************************************************************************/ +/* X and Y can be one dimensional if d omitted */ +/* */ +int forward(short tag, + int m, + int n, + int keep, + double *X, + double *Y) +/* forward(tag, m, n, keep, X[n], Y[m]) */ +{ return zos_forward(tag,m,n,keep,X,Y); +} + + +/****************************************************************************/ +/* general call */ +/* */ +int forward( short tag, + int m, + int n, + int d, + int p, + double *x, + double ***X, + double *y, + double ***Y) +/* forward(tag, m, n, d, p, x[n], X[n][p][d], y[m], Y[m][p][d]) */ +{ return hov_forward(tag,m,n,d,p,x,X,y,Y); +} + + +/****************************************************************************/ +/* general call */ +/* */ +int forward( short tag, + int m, + int n, + int p, + double *x, + double **X, + double *y, + double **Y) +/* forward(tag, m, n, p, x[n], X[n][p], y[m], Y[m][p]) */ +{ return fov_forward(tag,m,n,p,x,X,y,Y); +} + + +/****************************************************************************/ +/* REVERSE MODE, overloaded calls */ + +/****************************************************************************/ +/* general call */ +/* */ +int reverse( short tag, + int m, + int n, + int d, + double *u, + double **Z) +/* reverse(tag, m, n, d, u[m], Z[n][d+1]) */ +{ return hos_reverse(tag,m,n,d,u,Z); +} + + +/****************************************************************************/ +/* u can be a scalar if m=1 */ +/* */ +int reverse( short tag, + int m, + int n, + int d, + double u, + double **Z) +/* reverse(tag, 1, n, 0, u, Z[n][d+1]), m=1 => u scalar */ +{ int rc=-1; + + if (m != 1) + { fprintf(DIAG_OUT,"ADOL-C error: wrong u dimension in scalar-reverse \n"); + exit(-1); + } + else + rc = hos_reverse(tag,m,n,d,&u,Z); + + return rc; +} + + +/****************************************************************************/ +/* Z can be vector if d = 0; Done by specialized code */ +/* */ +int reverse( short tag, + int m, + int n, + int d, + double *u, + double *Z) +/* reverse(tag, m, n, 0, u[m], Z[n]), d=0 */ +{ if (d != 0) + { fprintf(DIAG_OUT,"ADOL-C error: wrong Z dimension in scalar-reverse \n"); + exit(-1); + } + + return fos_reverse(tag,m,n,u,Z); +} + + +/****************************************************************************/ +/* u and Z can be scalars if m=1 and d=0; */ +/* */ +int reverse( short tag, + int m, + int n, + int d, + double u, + double *Z) +/* reverse(tag, 1, n, 0, u, Z[n]), m=1 and d=0 => u and Z scalars */ +{ int rc=-1; + + if (m != 1 || d != 0 ) + { fprintf(DIAG_OUT,"ADOL-C error: wrong u or Z dimension in scalar-reverse \n"); + exit(-1); + } + else + rc = fos_reverse(tag,m,n,&u,Z); +\ + return rc; +} + + +/****************************************************************************/ +/* general call */ +/* */ +int reverse( short tag, + int m, + int n, + int d, + int q, + double **U, + double ***Z, + short **nz) +/* reverse(tag, m, n, d, q, U[q][m], Z[q][n][d+1], nz[q][n]) */ +{ return hov_reverse(tag,m,n,d,q,U,Z,nz); +} + + +/****************************************************************************/ +/* U can be a vector if m=1 */ +/* */ +int reverse( short tag, + int m, + int n, + int d, + int q, + double *U, + double ***Z, + short **nz) +/* reverse(tag, 1, n, d, q, U[q], Z[q][n][d+1], nz[q][n]), m=1 => u vector */ +{ int rc=-1; + + if (m != 1) + { fprintf(DIAG_OUT,"ADOL-C error: wrong U dimension in vector-reverse \n"); + exit(-1); + } + else + { /* olvo 980727 ??? */ + /* double** upp = new double*[nrows]; */ + double **upp = (double**) malloc(q*sizeof(double*)); + for (int i=0; i Z matrix */ +{ int rc=-1; + + if (d != 0) + { fprintf(DIAG_OUT,"ADOL-C error: wrong degree in vector-reverse \n"); + exit(-1); + } + else + rc = fov_reverse(tag,m,n,q,U,Z); + + return rc; +} + + +/****************************************************************************/ +/* */ +/* d=0 may be omitted, then Z may be a matrix; specialized code */ +/* */ +int reverse( short tag, + int m, + int n, + int q, + double **U, + double **Z) +/* reverse(tag, m, n, q, U[q][m], Z[q][n]), d=0 => Z matrix */ +{ int rc=-1; + + rc = fov_reverse(tag,m,n,q,U,Z); + + return rc; +} + + +/****************************************************************************/ +/* */ +/* If m=1 and d=0 then U can be vector and Z a matrix but no nz. */ +/* */ +int reverse( short tag, + int m, + int n, + int d, + int q, + double *U, + double **Z) +/* reverse(tag, 1, n, 0, q, U[q], Z[q][n]), + m=1 and d=0 => U vector and Z matrix but no nz */ +{ int rc=-1; + + /* olvo 981126 ??? what's that: */ + /* (++d)--; *//* degre is reserved for the future use. Ingore this line */ + + if ((m != 1) || (d != 0)) + { fprintf(DIAG_OUT,"ADOL-C error: wrong U dimension in vector-reverse \n"); + exit(-1); + } + else + { /* olvo 980727 ??? */ + /* double ** upp = new double*[nrows]; */ + double **upp = (double**) malloc(q*sizeof(double*)); + for (int i=0; i new: upd_resloc_inc_prod(..) + 981130 olvo: newly created by unification of taputil?.c + and all tape stuff + + History of taputil1.c: + 981030 olvo: bufsize --> BUFSIZE & TBUFSIZE + 981019 olvo: don't check sizeof(revreal) + 980914 olvo: unique size of stats block + 980825 olvo: #defines instead of const (C-Code!) + 980820 olvo: modification of statistic stuff + 980723 olvo: taputil3.* moved here + 980713 olvo: (1) no write_... routines anymore! + (2) statistic stuff kept here only + 980709 olvo: void write_pos_sign_a(..) + void write_neg_sign_a(..) + 980708 olvo: void write_upd(..) + 980707 olvo: void write_dot_av_av(..) + 980706 olvo: new operation code: incr_a + decr_a + (void write_incr_decr_a(..) ) + int_adb_d_one + int_adb_d_zero + 980703 olvo: new operation code: assign_d_one + assign_d_zero + 980623 olvo: new operation code: take_stock_op + + History of taputil2.c: + 980914 olvo: unique size of stats block + 980517 olvo: griewank's idea: + int upd_resloc(locint, locint); + + -------------------------------------------------------------- +*/ + +/****************************************************************************/ +/* INCLUDES */ +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" +#include "oplate.h" +#include "taputil.h" +#include "tayutil.h" + +#include +#include +#include + +#ifdef __cplusplus +#include +extern "C" { +#endif + + +/****************************************************************************/ +/* MACROS */ + +/*--------------------------------------------------------------------------*/ +#define min(a,b) ( (a)>(b)? (b):(a) ) + +/*--------------------------------------------------------------------------*/ +/* TAPE IDENTIFICATION (ADOLC & version check) */ +#define statSpace 22 +#define statSize 11 +#define adolcIDSize 5 +/* NOTE: adolcIDSize + statSize <= statSpace required! */ + + +/****************************************************************************/ +/* GLOBAL VARIABLES (external linkage) */ + +/*--------------------------------------------------------------------------*/ +/* Buffers for the operation tape, location tape, real tape. */ +unsigned char *op_codes; +locint *loc_tape; +double *real_tape; + +/*--------------------------------------------------------------------------*/ +/* Pointers into the operation tape, location tape, real tape */ +unsigned char *g_op_ptr; +locint *g_loc_ptr; +double *g_real_ptr; + +int op_ptr; +int loc_ptr; +int real_ptr; + +/*--------------------------------------------------------------------------*/ +/* Statistic stuff */ +int ind_ptr; +int dep_ptr; +int vs_ptr; +int revalso; + + +/****************************************************************************/ +/* LOCAL VARIABLES (internal linkage) */ + +/*--------------------------------------------------------------------------*/ +/* Max number of tapes currently in use */ +static int maxtapes = 0; + +/*--------------------------------------------------------------------------*/ +/* File Names */ +static char op_file_name[20]; +static char int_file_name[20]; +static char val_file_name[20]; + +/*--------------------------------------------------------------------------*/ +/* Arrays of pointers to the various tape buffers */ +static unsigned char **op_tape; +static locint **int_tape; +static double **val_tape; + +/*--------------------------------------------------------------------------*/ +/* Array of pointers to the stats arrays (of size statSize) */ +static int **stats; + +/*--------------------------------------------------------------------------*/ +static int tag; + +/*--------------------------------------------------------------------------*/ +/* Tape identification (ADOLC & version check) */ +int adolcID[] = { ADOLC_VERSION, + ADOLC_SUBVERSION, + ADOLC_PATCHLEVEL, + sizeof(locint), + sizeof(revreal) + }; + +/*--------------------------------------------------------------------------*/ +/* File pointers to the operation tape, location tape, real tape */ +static FILE *op_file_out; +static FILE *int_file_out; +static FILE *val_file_out; + +/*--------------------------------------------------------------------------*/ +/* Stats on operation tape, location tape, real tape */ +static int op_access_ptr, + int_access_ptr, + val_access_ptr; + +static int op_len_ptr, + int_len_ptr, + val_len_ptr; + +/*--------------------------------------------------------------------------*/ +/* Strings for the tape names (actual file names) */ +static char *op_file, + *int_file, + *val_file; + +/*--------------------------------------------------------------------------*/ +/* File counts */ +static long op_file_cnt, + int_file_cnt, + val_file_cnt; + +/*--------------------------------------------------------------------------*/ +/* Current buffer size */ +static int buff_size; + + +/****************************************************************************/ +/* INTERNAL FUNCTIONS */ + +/*--------------------------------------------------------------------------*/ +void fail( int error ) +{ switch (error) { + case -1: + fprintf(DIAG_OUT,"ADOL-C error: Malloc of memory failed!"); + exit (0); + } +} + +/*--------------------------------------------------------------------------*/ +/* int2asc converts the integer num to a string, places it + in the array string, and returns the pointer to the + string. (I now that this is rather redundant, but I + didn't write the original code for this.-- DWJ ;-) */ +char* int2asc( int num, char string[] ) +{ sprintf(string,"%d",num); + return(string); +} + + +/*--------------------------------------------------------------------------*/ +/* The subroutine get_fstr appends to the filename fname + the number fnum, and puts the resulting + string in fstr. */ +void get_fstr( char *fstr, short fnum, char *fname ) +/**** + The caller of this function is responsible for allocating the appropriate + amount of storage for fstr [strlen(FNAME)+1 <= strlen(fstr) + <= strlen(FNAME)+5] +****/ +{ char tstr[10]; + + if (fnum) + { strcpy (fstr,fname); + int2asc (fnum,tstr); + strcat (fstr,tstr); + } + else + { strcpy (fstr,fname); + fstr[strlen(fstr)-1] = '\0'; + } +} + +/*--------------------------------------------------------------------------*/ +/* The subroutine get_fstr appends to the filename FNAME + (found in usrparms.h) the number fnum, and puts the resulting + string in fstr. */ +void get_fstr1( char *fstr, short fnum ) +/**** + The caller of this function is responsible for allocating the appropriate + amount of storage for fstr [strlen(FNAME)+1 <= strlen(fstr) + <= strlen(FNAME)+5] +****/ +{ char tstr[10]; + + if (fnum) + { strcpy (fstr,FNAME1); + int2asc (fnum,tstr); + strcat (fstr,tstr); + } + else + { strcpy (fstr,FNAME1); + fstr[strlen(fstr)-1] = '\0'; + } +} + +/*--------------------------------------------------------------------------*/ +/* The subroutine get_fstr appends to the filename FNAME + (found in usrparms.h) the number fnum, and puts the resulting + string in fstr. */ +void get_fstr2( char *fstr, short fnum ) +/**** + The caller of this function is responsible for allocating the appropriate + amount of storage for fstr [strlen(FNAME)+1 <= strlen(fstr) + <= strlen(FNAME)+5] +****/ +{ char tstr[10]; + + if (fnum) + { strcpy (fstr,FNAME2); + int2asc (fnum,tstr); + strcat (fstr,tstr); + } + else + { strcpy (fstr,FNAME2); + fstr[strlen(fstr)-1] = '\0'; + } +} + + +/****************************************************************************/ +/* HELPFUL LOCALs */ + +/*--------------------------------------------------------------------------*/ +static void init_stat_space( short tnum ) +{ unsigned char **t1; /* t1,t2,t3 and t4 are temporaries */ + double **t2; + locint **t3; + int **t4; + int jj; + + /* Set up space for */ + if (maxtapes == 0) /*this is only done at first call to start_trace or + init_stat_space */ + { maxtapes = 10; + if (tnum >= maxtapes) + maxtapes = tnum + 10; + if ((op_tape = (unsigned char **)malloc(maxtapes*sizeof(unsigned char*))) == 0) + fail(-1); + if ((int_tape = (locint **)malloc(maxtapes*sizeof(locint *))) == 0) + fail(-1); + if ((val_tape = (double **)malloc(maxtapes*sizeof(double *))) == 0) + fail(-1); + + if ((stats = (int**)malloc(maxtapes*sizeof(int*))) == 0) + fail(-1); + for (jj=0; jj= maxtapes) + { int newtapes = tnum + 10; + t1 = op_tape; + t3 = int_tape; + t2 = val_tape; + t4 = stats; + if ((op_tape =(unsigned char**)malloc(newtapes*sizeof(unsigned char*))) == 0) + fail(-1); + if ((int_tape = (locint **)malloc(newtapes*sizeof(locint *))) == 0) + fail(-1); + if ((val_tape = (double **)malloc(newtapes*sizeof(double *))) == 0) + fail(-1); + if ((stats = (int**)malloc(newtapes*sizeof(int*))) == 0) + fail(-1); + + for (jj=0; jj buff_size-5) /* every operation writes <5 locations */ + { loc_tape[buff_size-1]=buff_size-loc_ptr; + put_locint_block(buff_size); + /* olvo 980720 old: put_to_op(end_of_int); */ + if (op_ptr == buff_size-1) /* every operation writes 1 opcode */ + { op_codes[op_ptr] = end_of_op; + put_op_block(buff_size); + op_codes[op_ptr++] = end_of_op; + } + op_codes[op_ptr++] = end_of_int; + } + if (real_ptr > buff_size-5) /* every operation writes <5 constants */ + { /* 3 should be sufficient */ + put_locint(buff_size-real_ptr); + put_val_block(buff_size); + /* olvo 980720 old: put_to_op(end_of_val); */ + if (op_ptr == buff_size-1) /* every operation writes 1 opcode */ + { op_codes[op_ptr] = end_of_op; + put_op_block(buff_size); + op_codes[op_ptr++] = end_of_op; + } + op_codes[op_ptr++] = end_of_val; + } + /* olvo 980720 old: put_to_op(op); */ + if (op_ptr == buff_size-1) /* every operation writes 1 opcode */ + { op_codes[op_ptr] = end_of_op; + put_op_block(buff_size); + op_codes[op_ptr++] = end_of_op; + } + op_codes[op_ptr++] = op; +} + +/*--------------------------------------------------------------------------*/ +/* Values */ +void put_val( double r_val ) +{ /* if (real_ptr == buff_size) put_val_block(buff_size); */ + real_tape[real_ptr++] = r_val; +} + +void put_vals_p( double *r_val, int size ) +{ int j; + for (j=0; j new: upd_resloc_inc_prod(..) + 990713 olvo: trace_on/off: default values for arguments + 981130 olvo: newly created by unification of taputil?.h + and all tape stuff + + History of taputil1.h: + 980914 olvo: adolcIDSize 5 (check size of locints ..) + 980825 olvo: #defines instead of const (C-Code!) + 980820 olvo: Version check + 980723 olvo: taputil3.* moved here + 980713 olvo: (1) no write_... routines anymore! + (2) statistic stuff kept here only + 980709 olvo: void write_pos_sign_a(..) + void write_neg_sign_a(..) + 980708 olvo: void write_upd(..) + 980707 olvo: void write_dot_av_av(..) + 980706 olvo: void write_incr_decr_a(..) + 980623 olvo: new operation code: take_stock_op + History of taputil2.h: + 980517 olvo: griewank's idea: + int upd_resloc(locint, locint); + + -------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/****************************************************************************/ +/****************************************************************************/ +/* PUBLIC EXPORTS */ + + +#ifdef __cplusplus +/****************************************************************************/ +/****************************************************************************/ +/* Now the C++ THINGS */ + +/****************************************************************************/ +/* TRACING ON/OFF (C++) */ +void trace_on( short, int = 0 ); +void trace_off( int = 0 ); + + +/****************************************************************************/ +/****************************************************************************/ +/* Now the C THINGS */ +extern "C" { +#endif + +/****************************************************************************/ +/* TAPE STATISTICS */ +extern void tapestats(short,int *); + + +/****************************************************************************/ +/* TRACING ON/OFF (C) */ +extern void start_trace(short,int); +extern void stop_trace(int,int); + + +#ifdef __cplusplus +} +#endif + + +/****************************************************************************/ +/****************************************************************************/ +/****************************************************************************/ +/* ADOL-C INTERNAL EXPORTS */ +#ifdef _ADOLC_SRC_ + + +#ifdef __cplusplus +/****************************************************************************/ +/****************************************************************************/ +/* No C++ THINGS */ + + +/****************************************************************************/ +/****************************************************************************/ +/* Now the C THINGS */ +extern "C" { +#endif + + +/****************************************************************************/ +/* GLOBAL VARIABLES */ + +/*--------------------------------------------------------------------------*/ +/* Statistic stuff. */ +extern int ind_ptr; +extern int dep_ptr; +extern int vs_ptr; +extern int revalso; + + +#ifndef HARDDEBUG +/*--------------------------------------------------------------------------*/ +/* Buffers for the operation tape, location tape, real tape. */ +extern unsigned char *op_codes; +extern locint *loc_tape; +extern double *real_tape; + +/*--------------------------------------------------------------------------*/ +/* Pointers into the operation tape, location tape, real tape */ +extern unsigned char *g_op_ptr; +extern locint *g_loc_ptr; +extern double *g_real_ptr; + +extern int op_ptr; +extern int loc_ptr; +extern int real_ptr; + +/*--------------------------------------------------------------------------*/ +/* MACRO or FUNCTION */ +#define get_op_f() *g_op_ptr++ +#define get_op_r() *(--g_op_ptr) + +#define get_locint_f() *g_loc_ptr++ +#define get_locint_r() *(--g_loc_ptr) + +#define get_val_f() *g_real_ptr++ +#define get_val_r() *(--g_real_ptr) + +#else /* HARDDEBUG */ +extern unsigned char get_op_f(void); +extern unsigned char get_op_r(void); + +extern locint get_locint_f(void); +extern locint get_locint_r(void); + +extern double get_val_f(void); +extern double get_val_r(void); +#endif + + +/****************************************************************************/ +/* CONTROL STUFF (inits, ends, etc.) */ +extern void init_for_sweep(int); +extern void init_rev_sweep(int); +extern void set_buf_size(int); +extern void set_buffers(char*,unsigned char*,char*, locint*,char*, double *); +extern void close_tape(int*, int); +extern void end_sweep(void); + + +/****************************************************************************/ +/* PUTs */ + +/*--------------------------------------------------------------------------*/ +/* Operations */ +extern void put_op(unsigned char); + +/*--------------------------------------------------------------------------*/ +/* Locations */ +extern void put_locint(locint); + +/*--------------------------------------------------------------------------*/ +/* Values */ +extern void put_val(double); +extern void put_vals_p(double *,int); +extern void put_vals_r(double *,int); + +/*--------------------------------------------------------------------------*/ +/* Update/correction of values or locations */ +extern void reset_val_r(void); +extern int upd_resloc(locint, locint); +extern int upd_resloc_inc_prod(locint, locint, unsigned char); + + +/****************************************************************************/ +/* GETs */ + +/*--------------------------------------------------------------------------*/ +/* Operations */ +extern void get_op_block_f(void); +extern void get_op_block_r(void); + +/*--------------------------------------------------------------------------*/ +/* Locations */ +extern void get_loc_block_f(void); +extern void get_loc_block_r(void); + +/*--------------------------------------------------------------------------*/ +/* Values */ +extern int get_val_space(void); +extern void get_val_block_f(void); +extern void get_val_block_r(void); +extern double * get_val_v_f(locint); +extern double * get_val_v_r(locint); + + +/****************************************************************************/ +/* UTILs */ +extern double make_nan(void); +extern double make_inf(void); + + +/****************************************************************************/ +/* THAT'S ALL */ +#ifdef __cplusplus +} +#endif + +#endif /* _ADOLC_SRC_ */ + +#endif + diff --git a/adol-c/SRC/taputilC.C b/adol-c/SRC/taputilC.C new file mode 100644 index 0000000..6a01a1d --- /dev/null +++ b/adol-c/SRC/taputilC.C @@ -0,0 +1,53 @@ +#define _TAPUTILC_CPP_ +#define _ADOLC_SRC_ +/* + -------------------------------------------------------------- + File taputilC.C of ADOL-C version 1.8.3 as of Jul/13/99 + -------------------------------------------------------------- + C++ interface for initialization and stopage of the taping + process + + Last changes: + 990713 olvo: trace_on/off: default values for arguments + 981130 olvo: newly created from utils.C + + -------------------------------------------------------------- +*/ + +/****************************************************************************/ +/* INCLUDES */ +#include "dvlparms.h" +#include "usrparms.h" +#include "taputil.h" +#include "adouble.h" + + +/****************************************************************************/ +/* TRACE_ON */ +/* Trace_on: + Initialization for the taping process. Sets up the arrays op_tape, + int_tape, val_tape, and stats. Op_tape, int_tape, val_tape are arrays + of pointers to individual buffers for operations, integers (locints), + and values (doubles). Also initializes buffers for this tape, sets + files names, and calls appropriate setup routines */ +void trace_on( short tnum, int revals ) +{ start_trace(tnum,revals); + take_stock(); /* record all existing adoubles on the tape */ +} + +/****************************************************************************/ +/* TRACE_OFF */ +/* Stop Tracing. Clean up, and turn off trace_flag */ +void trace_off( int flag ) +{ int locations; + locations = keep_stock(); /* copy remaining live variables and turns */ + /* off trace_flag */ + stop_trace(locations,flag); + cout.flush(); +} + + +/****************************************************************************/ +/* THAT'S ALL */ +#undef _ADOLC_SRC_ +#undef _TAPUTILC_CPP_ diff --git a/adol-c/SRC/tayutil.c b/adol-c/SRC/tayutil.c new file mode 100644 index 0000000..aa1501a --- /dev/null +++ b/adol-c/SRC/tayutil.c @@ -0,0 +1,360 @@ +#define _TAYUTILC_C_ +#define _ADOLC_SRC_ +/* + -------------------------------------------------------------- + File tayutilc.c of ADOL-C version 1.8.5 as of Nov/22/99 + -------------------------------------------------------------- + Taylor series utilities - primarily called from the module + hos_forward.c (--- a forward pass generates taylor + coefficients which need to be saved when a variable dies, or + is overwritten) and the reverse modules (-- to retrieve these + taylor coefficients to calculate the adjoints. + + Last changes: + 991122 olvo new op_codes eq_plus_prod eq_min_prod + for y += x1 * x2 + and y -= x1 * x2 + --> new: delete_scaylor(..) + 990816 olvo: ec in get_taylors + 990714 olvo: performance tuning (get_taylors) + 981201 olvo: changed file name to tayutilc.c + 980921 olvo: new interface of void overwrite_scaylor(..) to + allow correction of old overwrite in store + 980708 olvo (1) changed order in write_scaylor(..) + and write_taylor(..) + (2) new: void overwrite_scaylor(..) + + -------------------------------------------------------------- +*/ + +/****************************************************************************/ +/* INCLUDES */ + +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" +#include "tayutil.h" + +#include +#include + +#ifdef __cplusplus +#include +extern "C" { +#endif + + +/****************************************************************************/ +/* LOCAL VARIABLES (internal linkage) */ +static int numdep; +static int numind; + +static int T_file_access = 0; +static FILE* temp2_file = 0; +static int taylor_cnt; +static revreal * save_taylor = 0; +static int T_write_cnt; +static int T_blocks, + T_tail, + T_buf_size, + T_length; +static double **T; +static revreal **Tr; +static revreal *Trs; +static int degsave; + + +/****************************************************************************/ +/* ACCESS ROUTINES */ + +/*--------------------------------------------------------------------------*/ +/* Has a taylor file been written? */ +int taylor_access() +{ return T_file_access; +} + +/*--------------------------------------------------------------------------*/ +/* Close any open taylor file. */ +void close_taylor() +{ fclose(temp2_file); +} + +/****************************************************************************/ +/* LOCAL ROUTINES */ + +/*--------------------------------------------------------------------------*/ +/* T_Put_Block puts a block of tape to the disk. I assume this + is called only during a successive forward pass, computation. */ +static void T_put_block( int nitems ) +{ int n; + if (T_file_access == 0) + temp2_file = fopen(FNAME3,"w+b"); + if (T_write_cnt == 0) + fseek(temp2_file,0,0); + T_file_access = 1; + taylor_cnt = 0; + if ((n=fwrite((char *)save_taylor,sizeof(revreal)*nitems, + 1,temp2_file)) != 1) + { fprintf(DIAG_OUT,"ADOL-C error: fatal error-doing a write %d--- error %d\n", + n,errno); + switch (errno) { + case 28: /* ENOSPC */ + fprintf(DIAG_OUT,"No space left on device-contact sys. manager\n"); + break; + case 27: /* EFBIG */ + fprintf(DIAG_OUT,"File to big-- Taylor-tape space exhausted.\n"); + break; + default: + fprintf(DIAG_OUT,"Unexpected error %d .\n",errno); + break; + } + exit(-1); + } + T_write_cnt++; +} + +/*--------------------------------------------------------------------------*/ +/* Static function T_prev_block + called by taylor_back, taylor_back2, get_taylor, get_taylors + Gets the next (previous block) of size nitems */ +static int T_prev_block( int nitems ) +{ int n; +#ifdef DEBUG + fprintf(DIAG_OUT,"ADOL-C debug: prev %d =nitems %d T_write_cnt \n", nitems, T_write_cnt); +#endif + if (T_file_access) + { if (T_write_cnt == 0) + return 0; + T_write_cnt--; + fseek(temp2_file,T_buf_size*T_write_cnt*sizeof(revreal),0); + n=fread((char *)save_taylor,sizeof(revreal),nitems,temp2_file); + if (n != nitems) + { fprintf(DIAG_OUT,"ADOL-C error: Read error on taylor file n= %d\n",n); + return 0; + } + taylor_cnt = nitems; + return 1; + } + return 0; +} + + +/****************************************************************************/ +/* CONTROL STUFF */ + +/*--------------------------------------------------------------------------*/ +/* Close the taylor file, reset data. */ +void taylor_close( int buffer, int dep, int ind) +{ int n; + if (buffer == -1) + degsave = -1; /* enforces failure of reverse */ + numdep = dep; + numind = ind; + /* olvo 980708 changed to: ++.. */ + T_tail = ++taylor_cnt; + T_length = T_buf_size*T_write_cnt+taylor_cnt; + if (T_write_cnt) + { if (T_tail>0 ) + T_put_block(T_tail); + free((char *)save_taylor); + save_taylor = 0; + } + T_blocks = T_write_cnt; + if ((T_blocks) && (T_length*sizeof(revreal) <= buffer)) + { save_taylor = (revreal *) malloc(T_length*sizeof(revreal)); + if (save_taylor == NULL) + { fprintf(DIAG_OUT,"ADOL-C error: cannot allocate taylor buffer!\n"); + exit(-1); + } + fseek(temp2_file,0,0); + n = fread((char *)save_taylor,sizeof(revreal),T_length,temp2_file); + if ( n != T_length) + { fprintf(DIAG_OUT,"ADOL-C error: read error in taylor_close n= %d\n",n); + exit(-2); + } + T_tail = T_length; + T_blocks = 0; + } +#ifdef DEBUG + if (T_blocks) + fprintf(DIAG_OUT,"\n ADOL-C debug: taylor file of length %d bytes completed\n", T_length*sizeof(revreal)); + else + fprintf(DIAG_OUT,"\n ADOL-C debug: taylor array of length %d bytes completed\n", T_length*sizeof(revreal)); +#endif +} + +/*--------------------------------------------------------------------------*/ +/* Set up statics for writing taylor data */ +void taylor_begin( int buffer, double** Tg, int degree ) +{ T = Tg; + if (save_taylor) + free((char *)save_taylor); + T_buf_size = 1+buffer/sizeof(revreal); + save_taylor = (revreal *)malloc(sizeof(revreal)*T_buf_size); + if (save_taylor == NULL) + { fprintf(DIAG_OUT,"ADOL-C error: cannot allocate taylor buffer!\n"); + exit (-1); + } + T_write_cnt = 0; + T_length = 0; + taylor_cnt = 0; + degsave = degree; +} + + +/*--------------------------------------------------------------------------*/ +void taylor_back2( revreal** Trg, int* dep, int* ind, int* degree) +{ *dep = numdep; + *ind = numind; + *degree = degsave; + Tr = Trg; + T_write_cnt = T_blocks; + taylor_cnt = T_tail; + if (T_blocks == 0 && save_taylor == 0 ) + { fprintf(DIAG_OUT,"ADOL-C error: no temp file or array for reverse sweep \n"); + exit(-2); + } + if (T_blocks) + { if (save_taylor) + free((char*) save_taylor); + save_taylor = (revreal*) malloc(T_buf_size*sizeof(revreal)); + if (save_taylor == NULL) + { fprintf(DIAG_OUT,"ADOL-C error: cannot allocate taylor buffer!\n"); + exit (-1); + } + if (T_prev_block(T_tail) == 0) + fprintf(DIAG_OUT,"ADOL-C error: problems in taylorback2 \n"); + } +} + +/*--------------------------------------------------------------------------*/ +void taylor_back( revreal* Trg, int* dep, int* ind, int* degree) +{ *dep = numdep; + *ind = numind; + *degree = degsave; + Trs = Trg; + T_write_cnt = T_blocks; + taylor_cnt = T_tail; + if (T_blocks == 0 && save_taylor == 0 ) + { fprintf(DIAG_OUT,"ADOL-C error: no temp file or array for reverse sweep \n"); + exit(-2); + } + if (T_blocks) + { if (save_taylor) + free((char*) save_taylor); + save_taylor = (revreal*) malloc(T_buf_size*sizeof(revreal)); + if (save_taylor == NULL) + { fprintf(DIAG_OUT,"ADOL-C error: cannot allocate taylor buffer!\n"); + exit (-1); + } + if (T_prev_block(T_tail) == 0) + fprintf(DIAG_OUT,"ADOL-C error: problems in taylor_back \n"); + } +} + + +/****************************************************************************/ +/* WRITEs */ + +/*--------------------------------------------------------------------------*/ +/* Write_taylor writes the block of size depth of taylor coefficients + from point loc to the taylor buffer. If the buffer is filled, then + it is written to the taylor tape (T_put_block). */ +void write_taylor( locint loc, int depth ) +{ int i; + double* Tloc = T[loc]; + for (i=0;i= 0) + { for (i=0; i new: delete_scaylor(..) + 981130 olvo: automatic cleanup from utils.C moved here + 980921 olvo: new interface of void overwrite_scaylor(..) to + allow correction of old overwrite in store + 980708 olvo new: void overwrite_scaylor(..) + + -------------------------------------------------------------- +*/ + +/****************************************************************************/ +/****************************************************************************/ +/****************************************************************************/ +/* NO PUBLIC EXPORTS */ + + +/****************************************************************************/ +/****************************************************************************/ +/****************************************************************************/ +/* ADOL-C INTERNAL EXPORTS */ +#ifdef _ADOLC_SRC_ + + +#ifdef __cplusplus +/****************************************************************************/ +/****************************************************************************/ +/* Now the C++ THINGS */ + + + +/****************************************************************************/ +/****************************************************************************/ +/* Now the C THINGS */ +extern "C" { +#endif + + +/****************************************************************************/ +#ifndef __STDC__ + int unlink(char *); +#endif + + +/****************************************************************************/ +/* CONTROL STUFF */ +int taylor_access(); +void close_taylor(); +void taylor_begin( int, double**,int ); +void taylor_close( int, int, int ); +void taylor_back ( revreal*, int*, int*, int* ); +void taylor_back2( revreal**, int*, int*, int* ); + + +/****************************************************************************/ +/* WRITEs */ +void write_taylor( locint, int ); +void write_scaylor( revreal ); +/* olvo 980708 new nl */ +void overwrite_scaylor( revreal, revreal* ); +/* olvo 991122 new nl */ +void delete_scaylor( revreal* ); +void write_scaylors( double*, int ); + + +/****************************************************************************/ +/* GETs */ +void get_taylor( locint ); +void get_taylors( locint, int ); + +/****************************************************************************/ +/* THAT'S ALL */ +#ifdef __cplusplus +} +#endif + +#endif /* _ADOLC_SRC_ */ + +#endif + diff --git a/adol-c/SRC/tayutilC.C b/adol-c/SRC/tayutilC.C new file mode 100644 index 0000000..7556c14 --- /dev/null +++ b/adol-c/SRC/tayutilC.C @@ -0,0 +1,62 @@ +#define _TAYUTILC_CPP_ +#define _ADOLC_SRC_ +/* + -------------------------------------------------------------- + File tayutilC.C of ADOL-C version 1.8.0 as of Nov/30/98 + -------------------------------------------------------------- + The provided class clean_up makes sure the once the + program leaves, any temporary taylor file is deleted. + Last changes: + 981130 olvo: newly created from utils.C + + -------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/* INCLUDES */ +#include "dvlparms.h" +#include "usrparms.h" +#include "tayutil.h" + +#include + + +/****************************************************************************/ +/* CLASS CLEANUP */ +/* Added class clean-up, so that when the program leaves, it will clean + up the temporary file */ + +/*--------------------------------------------------------------------------*/ +/* class definition ( constructor & destructor only) */ +class cleanup { + int valid; +public: + cleanup(); + ~cleanup(); +}; + +cleanup::cleanup() +{ valid = 0; +} + +cleanup::~cleanup() +{ if (taylor_access()) + { close_taylor(); + remove(FNAME3); /* Complies with ANSI standard */ + /* unlink(FNAME3); works on some UNIX systems */ + } +} + + +/*--------------------------------------------------------------------------*/ +/* one static instance that does all work */ +static cleanup at_end; + + +/****************************************************************************/ +/* THAT'S ALL */ + +#undef _ADOLC_SRC_ +#undef _TAYUTILC_CPP_ + diff --git a/adol-c/SRC/uni5_for.c b/adol-c/SRC/uni5_for.c new file mode 100644 index 0000000..720df6a --- /dev/null +++ b/adol-c/SRC/uni5_for.c @@ -0,0 +1,3117 @@ +#define _UNI5_FOR_C_ +#define _ADOLC_SRC_ +/* + ---------------------------------------------------------------- + File uni5_for.c of ADOL-C version 1.8.7 as of Mar/10/2000 + ---------------------------------------------------------------- + Contains the routines : + zos_forward (zero-order-scalar forward mode) : define _ZOS_ + fos_forward (first-order-scalar forward mode) : define _FOS_ + hos_forward (higher-order-scalar forward mode) : define _HOS_ + fov_forward (first-order-vector forward mode) : define _FOV_ + hov_forward (higher-order-vector forward mode) : define _HOV_ + + Uses the preprocessor to compile the 5 different object files + with(scalar only)/without "keep" parameter : define _KEEP_ + + Last changed: + 20000310 olvo (1) better error messages for discontinuity + (2) removed trigraphs stuff + 991122 olvo new op_codes eq_plus_prod eq_min_prod + for y += x1 * x2 + and y -= x1 * x2 + 990816 olvo computation of size of value stack buffer + (=taylor buffer) changed in order to avoid + overflows allowing larger values of vs_size + (unsigned longs or even doubles for + counters considered for future developments) + 981130 olvo last check (includes ...) + 981030 olvo bufsize --> BUFSIZE & TBUFSIZE + 980929 olvo (1) new locint checkSize + (2) changed strategy to allow reflexive + - eq_mult_av_a, mult_a_av, div_av_a + 980924 olvo (1) allow reflexive operations for + - vector operations: eq_mult_av_a, + dot_av_av, mult_a_av, div_av_a + - cond_assign, cond_assign_s + (2) new macros TQO* + (3) deleted all int_* opcodes + 980923 olvo allow reflexive operations for + - min_op, abs_op + 980922 olvo allow reflexive operations for + - gen_quad + - div_d_a, div_a_a + 980921 olvo (1) changed save-order in sin/cos + (2) allow reflexive operations for + - sin/cos + - asin/acos/atan + - asinh/acosh/atanh + - erf, log, pow + 980915 olvo (1) modified mult_a_a to allow x = x*x + (2) correction of c&p-error in macros + (TARG_*, TARG1_*, TARG2_*) + (3) modified exp_op to allow x = exp(x) + 980820 olvo new comparison strategy + 980818 olvo ec BREAK_ZOS + 980721 olvo (1) ec in min_op, abs_op, ceil_op, floor_op + (2) write of taylors in subscript and + subscript_m + 980714 olvo some error elimination + op-code mult_av_a removed + 980710 olvo sin/cos writes 2 taylors + 980709 olvo new operation code: neg_sign_a + pos_sign_a + 980706 olvo new operation code: int_adb_d_one + int_adb_d_zero + 980703 olvo new operation code: assign_d_one + assign_d_zero + 980625 olvo vector operations & subscripts + 980624 olvo rearrangements + 980623 mitev/olvo revision + stock stuff + 980615 olvo griewank's idea + 980609 mitev + + ---------------------------------------------------------------- +*/ + + +/****************************************************************************/ +/* MACROS */ + +#undef _ADOLC_VECTOR_ +#undef _HI_ORDER_ + +/*--------------------------------------------------------------------------*/ +#ifdef _ZOS_ +#define GENERATED_FILENAME "zos_forward" + +/*--------------------------------------------------------------------------*/ +#elif _FOS_ +#define GENERATED_FILENAME "fos_forward" + +#define ARGUMENT(indexi,l,i) argument[indexi] +#define TAYLORS(indexd,l,i) taylors[indexd] + +/*--------------------------------------------------------------------------*/ +#elif _FOV_ +#define GENERATED_FILENAME "fov_forward" + +#define _ADOLC_VECTOR_ + +#define ARGUMENT(indexi,l,i) argument[indexi][l] +#define TAYLORS(indexd,l,i) taylors[indexd][l] + +/*--------------------------------------------------------------------------*/ +#elif _HOS_ +#define GENERATED_FILENAME "hos_forward" + +#define _HI_ORDER_ + +#define ARGUMENT(indexi,l,i) argument[indexi][i] +#define TAYLORS(indexd,l,i) taylors[indexd][i] + +/*--------------------------------------------------------------------------*/ +#elif _HOV_ +#define GENERATED_FILENAME "hov_forward" + +#define _ADOLC_VECTOR_ +#define _HI_ORDER_ + +#define ARGUMENT(indexi,l,i) argument[indexi][l][i] +#define TAYLORS(indexd,l,i) taylors[indexd][l][i] + +#else +#error Error ! Define [_ZOS_ | _FOS_ | _HOS_ | _FOV_ | _HOV_] [{_KEEP_}] +#endif + +/*--------------------------------------------------------------------------*/ +/* KEEP stuff */ +#ifdef _KEEP_ + +#ifdef _ADOLC_VECTOR_ /* no keep in vector mode */ +#define IF_KEEP_TAYLOR_CLOSE +#define IF_KEEP_WRITE_TAYLOR(res,keep) +#else /* _ZOS_, _FOS_, _HOS_ */ +#define IF_KEEP_TAYLOR_CLOSE \ +if (keep){\ + fprintf(DIAG_OUT,"Otherwise succeeding reverse sweep will fail!\n");\ + taylor_close(-1,depcheck,indcheck);\ +} +#ifdef _ZOS_ +#define IF_KEEP_WRITE_TAYLOR(res,keep) if (keep) write_scaylor(T0[res]); +#elif _FOS_ +#define IF_KEEP_WRITE_TAYLOR(res,keep) if (keep){ write_scaylor(T0[res]); \ +if (keep > 1) write_scaylor(T[res]);} +#elif _HOS_ +#define IF_KEEP_WRITE_TAYLOR(res,keep) if (keep){ write_scaylor(T0[res]); \ +if (keep > 1) write_taylor(res,keep-1);} +#endif +#endif + +#else /* no _KEEP_ */ +#define IF_KEEP_TAYLOR_CLOSE +#define IF_KEEP_WRITE_TAYLOR(res,keep) +#endif + +/*--------------------------------------------------------------------------*/ +/* access to variables */ +#ifndef _ZOS_ +#ifdef _FOS_ +#define TRES *Tres +#define TARG *Targ +#define TARG1 *Targ1 +#define TARG2 *Targ2 +#define TQO *Tqo + +#define TRES_INC *Tres +#define TARG_INC *Targ +#define TARG1_INC *Targ1 +#define TARG2_INC *Targ2 +#define TQO_INC *Tqo + +#define TRES_DEC *Tres +#define TARG_DEC *Targ +#define TARG1_DEC *Targ1 +#define TARG2_DEC *Targ2 +#define TQO_DEC *Tqo + +#define TRES_FOINC *Tres +#define TARG_FOINC *Targ +#define TARG1_FOINC *Targ1 +#define TARG2_FOINC *Targ2 +#define TQO_FOINC *Tqo + +#define TRES_FODEC *Tres +#define TARG_FODEC *Targ +#define TARG1_FODEC *Targ1 +#define TARG2_FODEC *Targ2 +#define TQO_FODEC *Tqo + +#define ASSIGN_T(a,b) a = &b; + +#else /* _HOS_, _FOV_, _HOV_ */ +#define TRES *Tres +#define TARG *Targ +#define TARG1 *Targ1 +#define TARG2 *Targ2 +#define TQO *Tqo + +#define TRES_INC *Tres++ +#define TARG_INC *Targ++ +#define TARG1_INC *Targ1++ +#define TARG2_INC *Targ2++ +#define TQO_INC *Tqo++ + +#define TRES_DEC *Tres-- +#define TARG_DEC *Targ-- +#define TARG1_DEC *Targ1-- +#define TARG2_DEC *Targ2-- +#define TQO_DEC *Tqo-- + +#ifdef _FOV_ +#define TRES_FOINC *Tres++ +#define TARG_FOINC *Targ++ +#define TARG1_FOINC *Targ1++ +#define TARG2_FOINC *Targ2++ +#define TQO_FOINC *Tqo++ + +#define TRES_FODEC *Tres-- +#define TARG_FODEC *Targ-- +#define TARG1_FODEC *Targ1-- +#define TARG2_FODEC *Targ2-- +#define TQO_FODEC *Tqo-- +#else /* _HOS_, _HOV_ */ +#define TRES_FOINC *Tres +#define TARG_FOINC *Targ +#define TARG1_FOINC *Targ1 +#define TARG2_FOINC *Targ2 +#define TQO_FOINC *Tqo + +#define TRES_FODEC *Tres +#define TARG_FODEC *Targ +#define TARG1_FODEC *Targ1 +#define TARG2_FODEC *Targ2 +#define TQO_FODEC *Tqo +#endif + +#define ASSIGN_T(a,b) a = b; +#endif +#endif + + +/*--------------------------------------------------------------------------*/ +/* loop stuff */ +#ifdef _ADOLC_VECTOR_ +#define FOR_0_LE_l_LT_p for (l=0; l=0; l--) +#else +#define FOR_0_LE_l_LT_p +#define FOR_p_GT_l_GE_0 +#endif + +#ifdef _HI_ORDER_ +#define FOR_0_LE_i_LT_k for (i=0; i=0; i--) +#else +#define FOR_0_LE_i_LT_k +#define FOR_k_GT_i_GE_0 +#endif + +#ifdef _HOV_ +#define FOR_0_LE_l_LT_pk for (l=0; l (b)) (a) = (b) + +/* END Macros */ + + +/****************************************************************************/ +/* NECESSARY INCLUDES */ +#include "dvlparms.h" /* Developers Parameters */ +#include "usrparms.h" /* Users Parameters */ +#include "interfaces.h" +#include "oplate.h" +#include "adalloc.h" +#include "taputil.h" +#include "tayutil.h" + +#include +#include + +#ifdef __cplusplus +#include +extern "C" { +#endif + + +/****************************************************************************/ +/* NOW THE CODE */ + +/*--------------------------------------------------------------------------*/ +/* Local Static Variables */ +static short tag; + +static int for_location_cnt; +static int dep_cnt; +static int ind_cnt; + +#ifndef _ADOLC_VECTOR_ +static int valstack; +#endif + +#ifdef _ZOS_ +/****************************************************************************/ +/* Zero Order Scalar version of the forward mode. */ +/****************************************************************************/ +#ifdef _KEEP_ +int zos_forward( +#else +int zos_forward_nk( +#endif + short tnum, /* tape id */ + int depcheck, /* consistency chk on # of deps */ + int indcheck, /* consistency chk on # of indeps */ +#ifdef _KEEP_ + int keep, /* flag for reverse sweep */ +#endif + double *basepoint, /* independant variable values */ + double *valuepoint) /* dependent variable values */ + + +#elif _FOS_ +/****************************************************************************/ +/* First Order Scalar version of the forward mode. */ +/****************************************************************************/ +#ifdef _KEEP_ +int fos_forward( +#else +int fos_forward_nk( +#endif + short tnum, /* tape id */ + int depcheck, /* consistency chk on # of deps */ + int indcheck, /* consistency chk on # of indeps */ +#ifdef _KEEP_ + int keep, /* flag for reverse sweep */ +#endif + double *basepoint, /* independent variable values */ + double *argument, /* Taylor coefficients (input) */ + double *valuepoint, /* Taylor coefficients (output) */ + double *taylors) /* matrix of coifficient vectors */ +/* the order of the indices in argument and taylors is [var][taylor] */ + + +#elif _FOV_ +/****************************************************************************/ +/* First Order Vector version of the forward mode. */ +/****************************************************************************/ +int fov_forward( + short tnum, /* tape id */ + int depcheck, /* consistency chk on # of deps */ + int indcheck, /* consistency chk on # of indeps */ + int p, /* # of taylor series */ + double *basepoint, /* independent variable values */ + double **argument, /* Taylor coefficients (input) */ + double *valuepoint, /* Taylor coefficients (output) */ + double **taylors) /* matrix of coifficient vectors */ +/* the order of the indices in argument and taylors is [var][taylor] */ + + +#elif _HOS_ +/****************************************************************************/ +/* Higher Order Scalar version of the forward mode. */ +/****************************************************************************/ +#ifdef _KEEP_ +int hos_forward( +#else +int hos_forward_nk( +#endif + short tnum, /* tape id */ + int depcheck, /* consistency chk on # of dependents */ + int indcheck, /* consistency chk on # of independents */ + int gdegree, /* highest derivative degree */ +#ifdef _KEEP_ + int keep, /* flag for reverse sweep */ +#endif + double *basepoint, /* independent variable values */ + double **argument, /* independant variable values */ + double *valuepoint, /* Taylor coefficients (output) */ + double **taylors) /* matrix of coifficient vectors */ + + +#elif _HOV_ + +/****************************************************************************/ +/* Higher Order Vector version of the forward mode. */ +/****************************************************************************/ +int hov_forward( + short tnum, /* tape id */ + int depcheck, /* consistency chk on # of deps */ + int indcheck, /* consistency chk on # of indeps */ + int gdegree, /* highest derivative degree */ + int p, /* # of taylor series */ + double *basepoint, /* independent variable values */ + double ***argument, /* Taylor coefficients (input) */ + double *valuepoint, /* Taylor coefficients (output) */ + double ***taylors) /* matrix of coifficient vectors */ +/* the order of the indices in argument and taylors is [var][taylor][deriv] */ + +#endif + +{ +/****************************************************************************/ +/* ALL VARIABLES */ + unsigned char operation; /* operation code */ + int tape_stats[11]; /* tape stats */ + int ret_c =3; /* return value */ + + locint size = 0; + locint res = 0; + locint arg = 0; + locint arg1 = 0; + locint arg2 = 0; + locint checkSize; + + double coval = 0, *d = 0; + + int indexi = 0, indexd = 0; + + /* loop indices */ + int i, j, l, ls; + + /* other necessary variables */ + double r0, x, y, divs; + int buffer, even, flag; + static int fax, kax, pax; + + /* Taylor stuff */ + static double *T0; +#ifndef _ZOS_ +#ifdef _FOS_ + static double *T; + double Ttemp; +#else + static double **T; + static double *Ttemp; +#endif + double *Tres, *Targ, *Targ1, *Targ2, *Tqo; + + double *TresOP, *TresOP2, *zOP; + double *TargOP, *Targ1OP, *Targ2OP, *TqoOP; +#endif + double T0temp; +#define T0res T0temp +#define T0arg T0temp + +#ifdef _HI_ORDER_ + static double *z; + int k = gdegree; +#endif + +#ifndef _ADOLC_VECTOR_ + int numoperations; +#endif + +#ifdef _KEEP_ + int taylbuf; +#endif + +#ifdef _HOV_ + int pk = k*p; +#endif + + +#ifdef DEBUG +/****************************************************************************/ +/* DEBUG MESSAGES */ + fprintf(DIAG_OUT,"Call of %s(..) with tag: %d, n: %d, m %d,\n", + GENERATED_FILENAME, tnum, indcheck, depcheck); +#ifdef _KEEP_ + fprintf(DIAG_OUT," keep: %d\n", keep); +#endif +#ifdef _HI_ORDER_ + fprintf(DIAG_OUT," degree: %d\n",gdegree); +#endif +#ifdef _ADOLC_VECTOR_ + fprintf(DIAG_OUT," p: %d\n\n",p); +#endif + +#endif + + +/****************************************************************************/ +/* INITs */ + +/* Set up stuff for the tape */ + tag = tnum; /*tag is global which specifies which tape to look at */ + + tapestats(tag,tape_stats); + ind_cnt = tape_stats[0]; + dep_cnt = tape_stats[1]; + for_location_cnt = tape_stats[2]; + buffer = tape_stats[4]; +#ifndef _ADOLC_VECTOR_ + /* olvo 980615 deleted nl + valstack = tape_stats[3]; + new n2l */ + valstack = tape_stats[3]; + numoperations = tape_stats[5]; + /*valstack = numoperations */ /* Hopefully an upper bound - says griewank */ + /* + for_location_cnt;*/ /* olvo 980618 ec think about that!!! */ +#endif + + set_buf_size(buffer); + + if ((depcheck != dep_cnt)||(indcheck != ind_cnt)) + { fprintf(DIAG_OUT,"ADOL-C error: forward sweep on tape %d aborted!\n",tag); + fprintf(DIAG_OUT,"Number of dependent and/or independent variables passed" + " to forward is\ninconsistant with number" + " recorded on tape %d \n",tag); + exit (-1); + } + + +/****************************************************************************/ +/* MEMORY ALLOCATION */ +/* olvo 980626 has to be revised for common blocks */ + +/*--------------------------------------------------------------------------*/ +#ifdef _ZOS_ /* ZOS */ +#ifdef _KEEP_ + if (keep>1){ + fprintf(DIAG_OUT,"\n ADOL-C error: zero order scalar forward cannot save" + " more\nthan zero order taylor coefficients!\n"); + exit (-1); + } +#endif + if (for_location_cnt compsize fax) + { if (fax) + free((char *) T0); + T0 = myalloc1(for_location_cnt); + fax = for_location_cnt; + } +#ifdef _KEEP_ + /* olvo 990816 new: */ + if (keep) + { taylbuf = TBUFSIZE/(keep*sizeof(revreal)); + taylbuf *= keep*sizeof(revreal); + taylor_begin(taylbuf,&T0,keep-1); + } +#endif + +/*--------------------------------------------------------------------------*/ +#elif _FOS_ /* FOS */ +#ifdef _KEEP_ + if (keep>2){ + fprintf(DIAG_OUT,"\n ADOL-C error: first order scalar forward cannot save" + " more \nthan first order taylor coefficients!\n"); + exit (-1); + } +#endif + if (for_location_cnt compsize fax) + { if (fax) + { free((char*) T0); + free((char*) T); + } + T0 = myalloc1(for_location_cnt); + T = myalloc1(for_location_cnt); + fax = for_location_cnt; + } +#ifdef _KEEP_ + /* olvo 990816 new: */ + if (keep) + { taylbuf = TBUFSIZE/(keep*sizeof(revreal)); + taylbuf *= keep*sizeof(revreal); + taylor_begin(taylbuf,&T,keep-1); + } +#endif + +/*--------------------------------------------------------------------------*/ +#elif _FOV_ /* FOV */ + if (p compsize pax || for_location_cnt compsize fax) + { if (pax || fax) + { free((char*) T0); + free((char*) *T); free((char*) T); + free((char*) Ttemp); + } + T0 = myalloc1(for_location_cnt); + T = myalloc2(for_location_cnt,p); + Ttemp = myalloc1(p); + pax = p; + fax = for_location_cnt; + } + +/*--------------------------------------------------------------------------*/ +#elif _HOS_ /* HOS */ + if (k compsize kax || for_location_cnt compsize fax) + { if (kax || fax) + { free((char*) T0); + free((char*) *T); free((char*) T); + free((char*) z); + free((char*) Ttemp); + } + T0 = myalloc1(for_location_cnt); + T = myalloc2(for_location_cnt,k); + z = myalloc1(k); + Ttemp = myalloc1(k); + kax = k; + fax = for_location_cnt; + } + +#ifdef _KEEP_ + /* olvo 990816 new: */ + if (keep) + { taylbuf = TBUFSIZE/(keep*sizeof(revreal)); + taylbuf *= keep*sizeof(revreal); + taylor_begin(taylbuf,T,keep-1); + } +#endif + +/*--------------------------------------------------------------------------*/ +#elif _HOV_ /* HOV */ + if (k compsize kax || for_location_cnt compsize fax || p compsize pax) + { if (kax || pax || fax) + { free((char*) T0); + free((char*) *T); free((char*) T); + free((char*) z); + free((char*) Ttemp); + } + T0 = myalloc1(for_location_cnt); + T = myalloc2(for_location_cnt,p*k); + z = myalloc1(k); + Ttemp = myalloc1(p*k); + kax = k; + fax = for_location_cnt; + pax = p ; + } +#endif + + +/****************************************************************************/ +/* FORWARD SWEEP */ + + /* Initialize the Forward Sweep */ + init_for_sweep(tag); + + operation=get_op_f(); + while (operation !=end_of_tape) + { switch (operation){ + + +/****************************************************************************/ +/* MARKERS */ + +/*--------------------------------------------------------------------------*/ + case end_of_op: /* end_of_op */ + get_op_block_f(); + operation=get_op_f(); + /* Skip next operation, it's another end_of_op */ + break; + +/*--------------------------------------------------------------------------*/ + case end_of_int: /* end_of_int */ + get_loc_block_f(); + break; + +/*--------------------------------------------------------------------------*/ + case end_of_val: /* end_of_val */ + get_val_block_f(); + break; +/*--------------------------------------------------------------------------*/ + case start_of_tape: /* start_of_tape */ + case end_of_tape: /* end_of_tape */ + break; + + +/****************************************************************************/ +/* COMPARISON */ + +/*--------------------------------------------------------------------------*/ + case eq_zero: /* eq_zero */ + arg = get_locint_f(); + + if (T0[arg] != 0) + { fprintf(DIAG_OUT, + "ADOL-C Warning: Branch switch detected in comparison " + "(operator eq_zero).\n" + "Forward sweep aborted! Retaping recommended!\n"); + IF_KEEP_TAYLOR_CLOSE + end_sweep(); + return (-1); + } + ret_c = 0; + break; + +/*--------------------------------------------------------------------------*/ + case neq_zero: /* neq_zero */ + arg = get_locint_f(); + + if (T0[arg] == 0) + { fprintf(DIAG_OUT, + "ADOL-C Warning: Branch switch detected in comparison " + "(operator neq_zero).\n" + "Forward sweep aborted! Retaping recommended!\n"); + IF_KEEP_TAYLOR_CLOSE + end_sweep(); + return (-1); + } + break; + +/*--------------------------------------------------------------------------*/ + case le_zero: /* le_zero */ + arg = get_locint_f(); + + if (T0[arg] > 0) + { fprintf(DIAG_OUT, + "ADOL-C Warning: Branch switch detected in comparison " + "(operator le_zero).\n" + "Forward sweep aborted! Retaping recommended!\n"); + IF_KEEP_TAYLOR_CLOSE + end_sweep(); + return (-1); + } + if (T0[arg] == 0) + ret_c = 0; + break; + +/*--------------------------------------------------------------------------*/ + case gt_zero: /* gt_zero */ + arg = get_locint_f(); + + if (T0[arg] <= 0) + { fprintf(DIAG_OUT, + "ADOL-C Warning: Branch switch detected in comparison " + "(operator gt_zero).\n" + "Forward sweep aborted! Retaping recommended!\n"); + IF_KEEP_TAYLOR_CLOSE + end_sweep(); + return (-1); + } + break; + +/*--------------------------------------------------------------------------*/ + case ge_zero: /* ge_zero */ + arg = get_locint_f(); + + if (T0[arg] < 0) + { fprintf(DIAG_OUT, + "ADOL-C Warning: Branch switch detected in comparison " + "(operator ge_zero).\n" + "Forward sweep aborted! Retaping recommended!\n"); + IF_KEEP_TAYLOR_CLOSE + end_sweep(); + return (-1); + } + if (T0[arg] == 0) + ret_c = 0; + break; + +/*--------------------------------------------------------------------------*/ + case lt_zero: /* lt_zero */ + arg = get_locint_f(); + + if (T0[arg] >= 0) + { fprintf(DIAG_OUT, + "ADOL-C Warning: Branch switch detected in comparison " + "(operator lt_zero).\n" + "Forward sweep aborted! Retaping recommended!\n"); + IF_KEEP_TAYLOR_CLOSE + end_sweep(); + return (-1); + } + break; + + +/****************************************************************************/ +/* ASSIGNMENTS */ + +/*--------------------------------------------------------------------------*/ + case assign_a: /* assign an adouble variable an assign_a */ + /* adouble value. (=) */ + arg = get_locint_f(); + res = get_locint_f(); + + IF_KEEP_WRITE_TAYLOR(res,keep) + + T0[res] = T0[arg]; +#ifndef _ZOS_ /* BREAK_ZOS */ + ASSIGN_T(Targ,T[arg]) + ASSIGN_T(Tres,T[res]) + + FOR_0_LE_l_LT_pk + TRES_INC = TARG_INC; + +#endif /* ALL_TOGETHER_AGAIN */ + break; + +/*--------------------------------------------------------------------------*/ + case assign_d: /* assign an adouble variable a assign_d */ + /* double value. (=) */ + res = get_locint_f(); + coval = get_val_f(); + + IF_KEEP_WRITE_TAYLOR(res,keep) + + T0[res] = coval; +#ifndef _ZOS_ /* BREAK_ZOS */ + ASSIGN_T(Tres, T[res]) + + FOR_0_LE_l_LT_pk + TRES_INC = 0; + +#endif /* ALL_TOGETHER_AGAIN */ + break; + +/*--------------------------------------------------------------------------*/ + case assign_d_zero: /* assign an adouble variable a assign_d_zero */ + /* double value. (0) (=) */ + res = get_locint_f(); + + IF_KEEP_WRITE_TAYLOR(res,keep) + + T0[res] = 0.0; +#ifndef _ZOS_ /* BREAK_ZOS */ + ASSIGN_T(Tres, T[res]) + + FOR_0_LE_l_LT_pk + TRES_INC = 0; + +#endif /* ALL_TOGETHER_AGAIN */ + break; + +/*--------------------------------------------------------------------------*/ + case assign_d_one: /* assign an adouble variable a assign_d_one */ + /* double value. (1) (=) */ + res = get_locint_f(); + + IF_KEEP_WRITE_TAYLOR(res,keep) + + T0[res] = 1.0; +#ifndef _ZOS_ /* BREAK_ZOS */ + ASSIGN_T(Tres, T[res]) + + FOR_0_LE_l_LT_pk + TRES_INC = 0; + +#endif /* ALL_TOGETHER_AGAIN */ + break; + +/*--------------------------------------------------------------------------*/ + case assign_ind: /* assign an adouble variable an assign_ind */ + /* independent double value (<<=) */ + res = get_locint_f(); + + IF_KEEP_WRITE_TAYLOR(res,keep) + + T0[res] = basepoint[indexi]; +#ifndef _ZOS_ /* BREAK_ZOS */ + ASSIGN_T(Tres, T[res]) + + FOR_0_LE_l_LT_p + FOR_0_LE_i_LT_k + TRES_INC = ARGUMENT(indexi,l,i); + +#endif /* ALL_TOGETHER_AGAIN */ + ++indexi; + break; + +/*--------------------------------------------------------------------------*/ + case assign_dep: /* assign a float variable a assign_dep */ + /* dependent adouble value. (>>=) */ + res = get_locint_f(); + + valuepoint[indexd] = T0[res]; +#ifndef _ZOS_ /* BREAK_ZOS */ + ASSIGN_T(Tres, T[res]) + + if (taylors != 0 ) /* ??? question: why here? */ + FOR_0_LE_l_LT_p + FOR_0_LE_i_LT_k + TAYLORS(indexd,l,i) = TRES_INC; + +#endif /* ALL_TOGETHER_AGAIN */ + indexd++; + break; + + +/****************************************************************************/ +/* OPERATION + ASSIGNMENT */ + +/*--------------------------------------------------------------------------*/ + case eq_plus_d: /* Add a floating point to an eq_plus_d */ + /* adouble. (+=) */ + res = get_locint_f(); + coval = get_val_f(); + + IF_KEEP_WRITE_TAYLOR(res,keep) + + T0[res] += coval; + break; + +/*--------------------------------------------------------------------------*/ + case eq_plus_a: /* Add an adouble to another eq_plus_a */ + /* adouble. (+=) */ + arg = get_locint_f(); + res = get_locint_f(); + + IF_KEEP_WRITE_TAYLOR(res,keep) + + T0[res] += T0[arg]; +#ifndef _ZOS_ /* BREAK_ZOS */ + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ, T[arg]) + + FOR_0_LE_l_LT_pk + TRES_INC += TARG_INC; + +#endif /* ALL_TOGETHER_AGAIN */ + break; + +/*--------------------------------------------------------------------------*/ + case eq_min_d: /* Subtract a floating point from an eq_min_d */ + /* adouble. (-=) */ + res = get_locint_f(); + coval = get_val_f(); + + IF_KEEP_WRITE_TAYLOR(res,keep) + + T0[res] -= coval; + break; + +/*--------------------------------------------------------------------------*/ + case eq_min_a: /* Subtract an adouble from another eq_min_a */ + /* adouble. (-=) */ + arg = get_locint_f(); + res = get_locint_f(); + + IF_KEEP_WRITE_TAYLOR(res,keep) + + T0[res] -= T0[arg]; +#ifndef _ZOS_ /* BREAK_ZOS */ + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ, T[arg]) + + FOR_0_LE_l_LT_pk + TRES_INC -= TARG_INC; + +#endif /* ALL_TOGETHER_AGAIN */ + break; + +/*--------------------------------------------------------------------------*/ + case eq_mult_d: /* Multiply an adouble by a eq_mult_d */ + /* flaoting point. (*=) */ + res = get_locint_f(); + coval = get_val_f(); + + IF_KEEP_WRITE_TAYLOR(res,keep) + + T0[res] *= coval; +#ifndef _ZOS_ /* BREAK_ZOS */ + ASSIGN_T(Tres, T[res]) + + FOR_0_LE_l_LT_pk + TRES_INC *= coval; + +#endif /* ALL_TOGETHER_AGAIN */ + break; + +/*--------------------------------------------------------------------------*/ + case eq_mult_a: /* Multiply one adouble by another eq_mult_a */ + /* (*=) */ + arg = get_locint_f(); + res = get_locint_f(); + + IF_KEEP_WRITE_TAYLOR(res,keep) + +#ifndef _ZOS_ /* BREAK_ZOS */ + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ, T[arg]) + + INC_pk_1(Tres) + INC_pk_1(Targ) + + FOR_p_GT_l_GE_0 + FOR_k_GT_i_GE_0 + { TRES_FODEC = T0[res]*TARG_DEC + TRES*T0[arg]; +#ifdef _HI_ORDER_ + TresOP = Tres-i; + TargOP = Targ; + + for (j=0;j0 */ +#endif /* _HI_ORDER_ */ + } + + +#endif /* ALL_TOGETHER_AGAIN */ + break; + +/*--------------------------------------------------------------------------*/ + case sin_op: /* sine operation sin_op */ + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + + IF_KEEP_WRITE_TAYLOR(arg2,keep) /* olvo 980710 covalue */ + IF_KEEP_WRITE_TAYLOR(res,keep) + + T0[arg2] = cos(T0[arg1]); /* Note: always arg2 != arg1 */ + T0[res] = sin(T0[arg1]); +#ifndef _ZOS_ /* BREAK_ZOS */ + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + ASSIGN_T(Targ2, T[arg2]) + + FOR_0_LE_l_LT_p + FOR_0_LE_i_LT_k + { /* olvo 980921 changed order to allow x = sin(x) */ +#ifdef _HI_ORDER_ + zOP = z+i; + (*zOP--) = (i+1) * (*Targ1); +#endif /* _HI_ORDER_ */ + + TARG2_FOINC = -T0[res] * TARG1; /* Note: always arg2 != arg1 */ + TRES_FOINC = T0[arg2] * TARG1_INC; + +#ifdef _HI_ORDER_ + TresOP = Tres-i; + Targ2OP = Targ2-i; + + *Tres *= (i+1); + *Targ2 *= (i+1); + for (j=0;j 0.0) + { r0 = make_nan(); + VEC_INC(Targ1, k-i) + BREAK_FOR_I + } + else + if (TARG1 < 0.0) + { r0 = make_inf(); + VEC_INC(Targ1, k-i) + BREAK_FOR_I + } + else + { r0 = 0.0; + Targ1++; + } + TRES = r0; + VEC_INC(Tres, k) + } + else + if (T0[arg1] == -1.0) + FOR_0_LE_l_LT_p + { FOR_0_LE_i_LT_k + if (TARG1 > 0.0) + { r0 = make_inf(); + VEC_INC(Targ1, k-i) + BREAK_FOR_I + } + else + if (TARG1 < 0.0) + { r0 = make_nan(); + VEC_INC(Targ1, k-i) + BREAK_FOR_I + } + else + { r0 = 0.0; + Targ1++; + } + TRES = r0; + VEC_INC(Tres, k) + } + else + FOR_0_LE_l_LT_p + { FOR_0_LE_i_LT_k + { /* olvo 980921 changed order to allow x = asin(x) */ +#ifdef _HI_ORDER_ + zOP = z+i; + (*zOP--) = (i+1) * (*Targ1); +#endif /* _HI_ORDER_ */ + + TRES_FOINC = T0[arg2] * TARG1_INC; + +#ifdef _HI_ORDER_ + Targ2OP = Targ2; + + *Tres *= (i+1); + for (j=0;j 0.0) + { r0 = make_nan(); + VEC_INC(Targ1, k-i) + BREAK_FOR_I + } + else + if (TARG1 < 0.0) + { r0 = -make_inf(); + VEC_INC(Targ1, k-i) + BREAK_FOR_I + } + else + { r0 = 0.0; + Targ1++; + } + TRES = r0; + VEC_INC(Tres, k) + } + else + if (T0[arg1] == -1.0) + FOR_0_LE_l_LT_p + { FOR_0_LE_i_LT_k + if (TARG1 > 0.0) + { r0 = -make_inf(); + VEC_INC(Targ1, k-i) + BREAK_FOR_I + } + else + if (TARG1 < 0.0) + { r0 = make_nan(); + VEC_INC(Targ1, k-i) + BREAK_FOR_I + } + else + { r0 = 0.0; + Targ1++; + } + TRES = r0; + VEC_INC(Tres, k) + } + else + FOR_0_LE_l_LT_p + { FOR_0_LE_i_LT_k + { /* olvo 980921 changed order to allow x = acos(x) */ +#ifdef _HI_ORDER_ + zOP = z+i; + (*zOP--) = (i+1) * (*Targ1); +#endif /* _HI_ORDER_ */ + + TRES_FOINC = T0[arg2] * TARG1_INC; + +#ifdef _HI_ORDER_ + Targ2OP = Targ2; + + *Tres *= (i+1); + for (j=0;j 0.0) + { r0 = make_inf(); + VEC_INC(Targ1, k-i) + BREAK_FOR_I + } + else + if (TARG1 < 0.0) + { r0 = make_nan(); + VEC_INC(Targ1, k-i) + BREAK_FOR_I + } + else + { r0 = 0.0; + Targ1++; + } + TRES_INC = r0; +#ifdef _HI_ORDER_ + for (i=1;i 0.0) + { r0 = make_nan(); + VEC_INC(Targ1, k-i) + BREAK_FOR_I + } + else + if (TARG1 < 0.0) + { r0 = make_inf(); + VEC_INC(Targ1, k-i) + BREAK_FOR_I + } + else + { r0 = 0.0; + Targ1++; + } + TRES_INC = r0; +#ifdef _HI_ORDER_ + for (i=1;i 0.0) + { r0 = make_inf(); + VEC_INC(Targ1, k-i) + BREAK_FOR_I + } + else + if (TARG1 < 0.0) + { r0 = make_nan(); + VEC_INC(Targ1, k-i) + BREAK_FOR_I + } + else + { r0 = 0.0; + Targ1++; + } + TRES_INC = r0; +#ifdef _HI_ORDER_ + for (i=1;i 0.0) + { if (coval <= 0.0) + r0 = make_nan(); + else + if (coval > 1.0) + r0 = 0.0; + else + if (coval == 1.0) + r0 = 1.0 ; + else /* coval < 1.0 */ + r0 = make_inf(); + VEC_INC(Targ, k-i) + BREAK_FOR_I + } + else + if (TARG < 0.0) + { r0 = make_nan(); + VEC_INC(Targ, k-i) + BREAK_FOR_I + } + else + { r0 = 0.0; + Targ++; + } + } + TRES_INC = r0; +#ifdef _HI_ORDER_ + for (i=1;i T0[res] == 0.0 */ + { r0 = 0.0; + FOR_0_LE_i_LT_k + { if (TARG>0.0) + { r0 = make_inf(); + VEC_INC(Targ, k-i) + BREAK_FOR_I + } + else + if (TARG<0.0) + { r0 = make_nan(); + VEC_INC(Targ, k-i) + BREAK_FOR_I + } + else + Targ++; + } + } + else + { r0 = 0.5/T0[res]; + } + Targ = TargOP; + + even = 1; + FOR_0_LE_i_LT_k + { TRES_FOINC = r0 * TARG_INC; +#ifdef _HI_ORDER_ + TresOP = Tres-i; + TresOP2 = Tres-1; + + x = 0; + for (j=1;2*j-1 T0[arg2]) + { if (coval) + MINDEC(ret_c,2); + } + else + if (T0[arg1] < T0[arg2]) + { if (!coval) + MINDEC(ret_c,2); + } + else + if (arg1 != arg2) + MINDEC(ret_c,1); + +#ifndef _ZOS_ /* BREAK_ZOS */ + ASSIGN_T(Targ1, T[arg1]) + ASSIGN_T(Targ2, T[arg2]) + ASSIGN_T(Tres, T[res]) + + Tqo = NULL; + if (T0[arg1] > T0[arg2]) + Tqo = Targ2; + else + if (T0[arg1] < T0[arg2]) + Tqo = Targ1; + + FOR_0_LE_l_LT_p + { Targ = Tqo; + if (Targ == NULL) /* e.g. T0[arg1] == T0[arg2] */ + { Targ1OP = Targ1; + Targ2OP = Targ2; + FOR_0_LE_i_LT_k + { if (TARG1 > TARG2) + { Targ = Targ2OP; + VEC_INC(Targ1, k-i) + VEC_INC(Targ2, k-i) + BREAK_FOR_I + } + else + if (TARG1 < TARG2) + { Targ = Targ1OP; + VEC_INC(Targ1, k-i) + VEC_INC(Targ2, k-i) + BREAK_FOR_I + } + Targ1++; Targ2++; + } + if (Targ == NULL) /* e.g. both are equal */ + Targ = Targ1OP; + } + + FOR_0_LE_i_LT_k + TRES_INC = TARG_INC; + + if (Tqo) + { VEC_INC(Tqo, k) + } + } + +#endif /* ALL_TOGETHER_AGAIN */ + T0[res] = FMIN(T0[arg1], T0[arg2]); + break; + +/*--------------------------------------------------------------------------*/ + case abs_val: /* abs_val */ + arg = get_locint_f(); + res = get_locint_f(); + coval = get_val_f(); + + IF_KEEP_WRITE_TAYLOR(res,keep) + + /* olvo 980923 changed order to allow x = min(x,y) etc. */ + + /* olvo/mitev 980721 ec n3l (taken from below) */ + if (T0[arg] < 0.0) + { if (coval) + MINDEC(ret_c,2); + } + else + if (T0[arg] > 0.0) + { if (!coval) + MINDEC(ret_c,2); + } + +#ifndef _ZOS_ /* BREAK_ZOS */ + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ, T[arg]) + + y = 0.0; + if (T0[arg] != 0.0) + if (T0[arg] < 0.0) + y = -1.0; + else + y = 1.0; + + FOR_0_LE_l_LT_p + { x = y; + FOR_0_LE_i_LT_k + { if ((x == 0.0) && (TARG != 0.0)) + { MINDEC(ret_c,1); + if (TARG < 0.0) + x = -1.0; + else + x = 1.0; + } + TRES_INC = x * TARG_INC; + } + } + +#endif /* ALL_TOGETHER_AGAIN */ + T0[res] = fabs(T0[arg]); + break; + +/*--------------------------------------------------------------------------*/ + case ceil_op: /* ceil_op */ + arg = get_locint_f(); + res = get_locint_f(); + coval = get_val_f(); + + IF_KEEP_WRITE_TAYLOR(res,keep) + + T0[res]=ceil(T0[arg]); + /* olvo/mitev 980721 ec n2l (taken from below) */ + if (coval != T0[res]) + MINDEC(ret_c,2); +#ifndef _ZOS_ /* BREAK_ZOS */ + ASSIGN_T(Tres, T[res]) + + FOR_0_LE_l_LT_pk + TRES_INC = 0.0; + +#endif /* ALL_TOGETHER_AGAIN */ + break; + +/*--------------------------------------------------------------------------*/ + case floor_op: /* Compute ceil of adouble floor_op */ + arg = get_locint_f(); + res = get_locint_f(); + coval = get_val_f(); + + IF_KEEP_WRITE_TAYLOR(res,keep) + + T0[res] = floor(T0[arg]); + /* olvo/mitev 980721 ec n2l (taken from below) */ + if (coval != T0[res]) + MINDEC(ret_c,2); +#ifndef _ZOS_ /* BREAK_ZOS */ + ASSIGN_T(Tres, T[res]) + + FOR_0_LE_l_LT_pk + TRES_INC = 0.0; + +#endif /* ALL_TOGETHER_AGAIN */ + break; + + +/****************************************************************************/ +/* CONDITIONALS */ + +/*--------------------------------------------------------------------------*/ + case cond_assign: /* cond_assign */ + arg = get_locint_f(); + arg1 = get_locint_f(); + arg2 = get_locint_f(); + res = get_locint_f(); + coval = get_val_f(); + + IF_KEEP_WRITE_TAYLOR(res,keep) + + /* olvo 980924 changed order to allow reflexive ops */ +#ifndef _ZOS_ /* BREAK_ZOS */ + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + ASSIGN_T(Targ2, T[arg2]) + + if (T0[arg] > 0) + FOR_0_LE_l_LT_pk + TRES_INC = TARG1_INC; + else + FOR_0_LE_l_LT_pk + TRES_INC = TARG2_INC; +#endif /* ALL_TOGETHER_AGAIN */ + + if (T0[arg] > 0) + { if (coval <= 0.0) + MINDEC(ret_c,2); + T0[res] = T0[arg1]; + } + else + { if (coval > 0.0) + MINDEC(ret_c,2); + if (T0[arg] == 0) + MINDEC(ret_c,0); + T0[res] = T0[arg2]; + } + break; + +/*--------------------------------------------------------------------------*/ + case cond_assign_s: /* cond_assign_s */ + arg = get_locint_f(); + arg1 = get_locint_f(); + res = get_locint_f(); + coval = get_val_f(); + + IF_KEEP_WRITE_TAYLOR(res,keep) + + /* olvo 980924 changed order to allow reflexive ops */ +#ifndef _ZOS_ /* BREAK_ZOS */ + ASSIGN_T(Tres, T[res]) + ASSIGN_T(Targ1, T[arg1]) + + if (T0[arg] > 0) + FOR_0_LE_l_LT_pk + TRES_INC = TARG1_INC; +#endif /* ALL_TOGETHER_AGAIN */ + + if (T0[arg] > 0) + { if (coval <= 0.0) + MINDEC(ret_c,2); + T0[res] = T0[arg1]; + } + else + if (T0[arg] == 0) + MINDEC(ret_c,0); + break; + + +/****************************************************************************/ +/* VECTOR ASSIGNMENTS */ + +/*--------------------------------------------------------------------------*/ + case assign_av: /* assign_av */ + arg = get_locint_f(); + size = get_locint_f(); + res = get_locint_f(); + + for (ls=0; ls= arg1) && (res < arg1+size)) + || ((res >= arg2) && (res < arg2+size)) ) + { ASSIGN_T(TresOP, Ttemp) + flag = 1; + } + else + { ASSIGN_T(TresOP, T[res]) + flag = 0; + } + + Tres = TresOP; + FOR_0_LE_l_LT_pk + TRES_INC = 0.0; +#endif /* ALL_TOGETHER_AGAIN */ + + for (ls=0; ls BUFSIZE & TBUFSIZE + 980723 olvo new: DIAG_OUT as standard output + FNAME3 as vs output + ---------------------------------------------------------------- +*/ + +/****************************************************************************/ +/* Buffer size for tapes */ +#define BUFSIZE 524288 /* 16384, 65536 or 524288 */ + + +/****************************************************************************/ +/* Buffer size for temporary Taylor store */ +#define TBUFSIZE 524288 /* 16384, 65536 or 524288 */ + + +/****************************************************************************/ +/* ADOL-C data types */ +#define locint unsigned short +#define revreal double + + +/****************************************************************************/ +/* Definionion of inf and NaN */ +#define inf_num 1.0 /* don't undefine these; on non-IEEE machines */ +#define inf_den 0.0 /* change the values to get small fractions */ +#define non_num 0.0 /* (inf_num/inf_den) and (non_num/non_den) */ +#define non_den 0.0 /* respectively, see the documentation */ + + +/****************************************************************************/ +/* File names */ +#define FNAME3 "_adol-vs_tape" +#define FNAME2 "_adol-rl_tape." +#define FNAME1 "_adol-in_tape." +#define FNAME "_adol-op_tape." + + +/****************************************************************************/ +/* Enable/disable DEBUG for hard debugging */ +/* #define DEBUG */ + + +/****************************************************************************/ +/* Enable/disable asinh, acosh,atanh, erf */ +/* #define ATRIG_ERF */ + + +/****************************************************************************/ +/* Standard output used for diagnostics by ADOL-C, */ +/* e.g. stdout or stderr or whatever file identifier */ +#define DIAG_OUT stdout + + +/****************************************************************************/ +/* Types used by Fortran callable versions of functions */ +#define fint long +#define fdouble double + + +/****************************************************************************/ +/* Use 'calloc' instead of 'malloc' in ADOL-C allocation routines */ +/* If you have any trouble with uninitialized memory then uncomment the + macro definition! */ +/* #define USE_CALLOC */ +#define USE_CALLOC + + +/****************************************************************************/ +/* That's all */ +#endif + + + diff --git a/adol-c/SRC/usrparms.h.ori b/adol-c/SRC/usrparms.h.ori new file mode 100644 index 0000000..8cb6f2e --- /dev/null +++ b/adol-c/SRC/usrparms.h.ori @@ -0,0 +1,92 @@ +#ifndef _USRPARMS_H_ +#define _USRPARMS_H_ +/* + ---------------------------------------------------------------- + File usrparms.h of ADOL-C version 1.8.6 as of Feb/14/2000 + ---------------------------------------------------------------- + + usrparms.h contains the parameters which might affect + the performance of the ADOL-C system. Intended to be tweeked by + users and local maintainence personal. + + Last changes: + 20000214 olvo The defininition of the macro USE_CALLOC + forces the ADOL-C allocation routines + to use 'calloc' instead of 'malloc'. + This may help in case of problems with + uninitialized memory as reported by Andreas + Waechter from CMU. + 981130 olvo Fortran types + 981030 olvo bufsize --> BUFSIZE & TBUFSIZE + 980723 olvo new: DIAG_OUT as standard output + FNAME3 as vs output + ---------------------------------------------------------------- +*/ + +/****************************************************************************/ +/* Buffer size for tapes */ +#define BUFSIZE 65536 /* 16384 or 524288 */ + + +/****************************************************************************/ +/* Buffer size for temporary Taylor store */ +#define TBUFSIZE 65536 /* 16384 or 524288 */ + + +/****************************************************************************/ +/* ADOL-C data types */ +#define locint unsigned short +#define revreal double + + +/****************************************************************************/ +/* Definionion of inf and NaN */ +#define inf_num 1.0 /* don't undefine these; on non-IEEE machines */ +#define inf_den 0.0 /* change the values to get small fractions */ +#define non_num 0.0 /* (inf_num/inf_den) and (non_num/non_den) */ +#define non_den 0.0 /* respectively, see the documentation */ + + +/****************************************************************************/ +/* File names */ +#define FNAME3 "_adol-vs_tape" +#define FNAME2 "_adol-rl_tape." +#define FNAME1 "_adol-in_tape." +#define FNAME "_adol-op_tape." + + +/****************************************************************************/ +/* Enable/disable DEBUG for hard debugging */ +/* #define DEBUG */ + + +/****************************************************************************/ +/* Enable/disable asinh, acosh,atanh, erf */ +/* #define ATRIG_ERF */ + + +/****************************************************************************/ +/* Standard output used for diagnostics by ADOL-C, */ +/* e.g. stdout or stderr or whatever file identifier */ +#define DIAG_OUT stdout + + +/****************************************************************************/ +/* Types used by Fortran callable versions of functions */ +#define fint long +#define fdouble double + + +/****************************************************************************/ +/* Use 'calloc' instead of 'malloc' in ADOL-C allocation routines */ +/* If you have any trouble with uninitialized memory then uncomment the + macro definition! */ +/* #define USE_CALLOC */ + + +/****************************************************************************/ +/* That's all */ +#endif + + + diff --git a/configure b/configure new file mode 100755 index 0000000..7cf4492 --- /dev/null +++ b/configure @@ -0,0 +1,2398 @@ +#! /bin/sh + +# Guess values for system-dependent variables and create Makefiles. +# Generated automatically using autoconf version 2.13 +# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc. +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. + +# Defaults: +ac_help= +ac_default_prefix=/usr/local +# Any additions from configure.in: +ac_help="$ac_help + --with-tcl directory containing tcl configuration (tclConfig.sh)" +ac_help="$ac_help + --disable-shared disable dynamic loading of HQP/Omuses" +ac_help="$ac_help + --with-tclinclude directory containing include file tcl.h" +ac_help="$ac_help + --enable-fortran include DASPK and RKsuite with Omuses" +ac_help="$ac_help + --enable-gmalloc link ODC with GNU malloc" +ac_help="$ac_help + --enable-cute include CUTE interface with HQP" +ac_help="$ac_help + --enable-ascend include preliminary Ascend4 interface with HQP" + +# Initialize some variables set by options. +# The variables have the same names as the options, with +# dashes changed to underlines. +build=NONE +cache_file=./config.cache +exec_prefix=NONE +host=NONE +no_create= +nonopt=NONE +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +target=NONE +verbose= +x_includes=NONE +x_libraries=NONE +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datadir='${prefix}/share' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +libdir='${exec_prefix}/lib' +includedir='${prefix}/include' +oldincludedir='/usr/include' +infodir='${prefix}/info' +mandir='${prefix}/man' + +# Initialize some other variables. +subdirs= +MFLAGS= MAKEFLAGS= +SHELL=${CONFIG_SHELL-/bin/sh} +# Maximum number of lines to put in a shell here document. +ac_max_here_lines=12 + +ac_prev= +for ac_option +do + + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval "$ac_prev=\$ac_option" + ac_prev= + continue + fi + + case "$ac_option" in + -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; + *) ac_optarg= ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case "$ac_option" in + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir="$ac_optarg" ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build="$ac_optarg" ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file="$ac_optarg" ;; + + -datadir | --datadir | --datadi | --datad | --data | --dat | --da) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ + | --da=*) + datadir="$ac_optarg" ;; + + -disable-* | --disable-*) + ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + eval "enable_${ac_feature}=no" ;; + + -enable-* | --enable-*) + ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "enable_${ac_feature}='$ac_optarg'" ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix="$ac_optarg" ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he) + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat << EOF +Usage: configure [options] [host] +Options: [defaults in brackets after descriptions] +Configuration: + --cache-file=FILE cache test results in FILE + --help print this message + --no-create do not create output files + --quiet, --silent do not print \`checking...' messages + --version print the version of autoconf that created configure +Directory and file names: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [same as prefix] + --bindir=DIR user executables in DIR [EPREFIX/bin] + --sbindir=DIR system admin executables in DIR [EPREFIX/sbin] + --libexecdir=DIR program executables in DIR [EPREFIX/libexec] + --datadir=DIR read-only architecture-independent data in DIR + [PREFIX/share] + --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data in DIR + [PREFIX/com] + --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var] + --libdir=DIR object code libraries in DIR [EPREFIX/lib] + --includedir=DIR C header files in DIR [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include] + --infodir=DIR info documentation in DIR [PREFIX/info] + --mandir=DIR man documentation in DIR [PREFIX/man] + --srcdir=DIR find the sources in DIR [configure dir or ..] + --program-prefix=PREFIX prepend PREFIX to installed program names + --program-suffix=SUFFIX append SUFFIX to installed program names + --program-transform-name=PROGRAM + run sed PROGRAM on installed program names +EOF + cat << EOF +Host type: + --build=BUILD configure for building on BUILD [BUILD=HOST] + --host=HOST configure for HOST [guessed] + --target=TARGET configure for TARGET [TARGET=HOST] +Features and packages: + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --x-includes=DIR X include files are in DIR + --x-libraries=DIR X library files are in DIR +EOF + if test -n "$ac_help"; then + echo "--enable and --with options recognized:$ac_help" + fi + exit 0 ;; + + -host | --host | --hos | --ho) + ac_prev=host ;; + -host=* | --host=* | --hos=* | --ho=*) + host="$ac_optarg" ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir="$ac_optarg" ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir="$ac_optarg" ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir="$ac_optarg" ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir="$ac_optarg" ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst \ + | --locals | --local | --loca | --loc | --lo) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* \ + | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) + localstatedir="$ac_optarg" ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir="$ac_optarg" ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir="$ac_optarg" ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix="$ac_optarg" ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix="$ac_optarg" ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix="$ac_optarg" ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name="$ac_optarg" ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir="$ac_optarg" ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir="$ac_optarg" ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site="$ac_optarg" ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir="$ac_optarg" ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir="$ac_optarg" ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target="$ac_optarg" ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers) + echo "configure generated by autoconf version 2.13" + exit 0 ;; + + -with-* | --with-*) + ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "with_${ac_package}='$ac_optarg'" ;; + + -without-* | --without-*) + ac_package=`echo $ac_option|sed -e 's/-*without-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + eval "with_${ac_package}=no" ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes="$ac_optarg" ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries="$ac_optarg" ;; + + -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } + ;; + + *) + if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then + echo "configure: warning: $ac_option: invalid host type" 1>&2 + fi + if test "x$nonopt" != xNONE; then + { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } + fi + nonopt="$ac_option" + ;; + + esac +done + +if test -n "$ac_prev"; then + { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } +fi + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +# File descriptor usage: +# 0 standard input +# 1 file creation +# 2 errors and warnings +# 3 some systems may open it to /dev/tty +# 4 used on the Kubota Titan +# 6 checking for... messages and results +# 5 compiler messages saved in config.log +if test "$silent" = yes; then + exec 6>/dev/null +else + exec 6>&1 +fi +exec 5>./config.log + +echo "\ +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. +" 1>&5 + +# Strip out --no-create and --no-recursion so they do not pile up. +# Also quote any args containing shell metacharacters. +ac_configure_args= +for ac_arg +do + case "$ac_arg" in + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) ;; + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) + ac_configure_args="$ac_configure_args '$ac_arg'" ;; + *) ac_configure_args="$ac_configure_args $ac_arg" ;; + esac +done + +# NLS nuisances. +# Only set these to C if already set. These must not be set unconditionally +# because not all systems understand e.g. LANG=C (notably SCO). +# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'! +# Non-C LC_CTYPE values break the ctype check. +if test "${LANG+set}" = set; then LANG=C; export LANG; fi +if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi +if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi +if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -rf conftest* confdefs.h +# AIX cpp loses on an empty file, so make sure it contains at least a newline. +echo > confdefs.h + +# A filename unique to this package, relative to the directory that +# configure is in, which we can look for to find out if srcdir is correct. +ac_unique_file=hqp/Hqp.h + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then its parent. + ac_prog=$0 + ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` + test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. + srcdir=$ac_confdir + if test ! -r $srcdir/$ac_unique_file; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r $srcdir/$ac_unique_file; then + if test "$ac_srcdir_defaulted" = yes; then + { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } + else + { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } + fi +fi +srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` + +# Prefer explicitly selected file to automatically selected ones. +if test -z "$CONFIG_SITE"; then + if test "x$prefix" != xNONE; then + CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" + else + CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" + fi +fi +for ac_site_file in $CONFIG_SITE; do + if test -r "$ac_site_file"; then + echo "loading site script $ac_site_file" + . "$ac_site_file" + fi +done + +if test -r "$cache_file"; then + echo "loading cache $cache_file" + . $cache_file +else + echo "creating cache $cache_file" + > $cache_file +fi + +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross + +ac_exeext= +ac_objext=o +if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then + # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. + if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then + ac_n= ac_c=' +' ac_t=' ' + else + ac_n=-n ac_c= ac_t= + fi +else + ac_n= ac_c='\c' ac_t= +fi + + + +MAJOR_VERSION=1 +MINOR_VERSION=7 +PATCHLEVEL=b1 + +VERSION=${MAJOR_VERSION}.${MINOR_VERSION}${PATCHLEVEL} + +cat >> confdefs.h <&6 +echo "configure:564: checking --with-tcl" >&5 +# Check whether --with-tcl or --without-tcl was given. +if test "${with_tcl+set}" = set; then + withval="$with_tcl" + with_tcl=$withval +fi + +echo "$ac_t"""$with_tcl"" 1>&6 + +if test ! -z "${with_tcl}"; then + echo $ac_n "checking for existence of ${with_tcl}/tclConfig.sh""... $ac_c" 1>&6 +echo "configure:575: checking for existence of ${with_tcl}/tclConfig.sh" >&5 + if test -f "${with_tcl}/tclConfig.sh" ; then + echo "$ac_t""loading" 1>&6 + . ${with_tcl}/tclConfig.sh + else + echo "$ac_t""file not found" 1>&6 + { echo "configure: error: wrong --with-tcl specification" 1>&2; exit 1; } + fi + # apply eval to vars used from tclConfig.h + # (this documents and it is partly required for substituitions) + eval TCL_VERSION=${TCL_VERSION} + eval TCL_MAJOR_VERSION=${TCL_MAJOR_VERSION} + eval TCL_MINOR_VERSION=${TCL_MINOR_VERSION} + eval TCL_PREFIX=${TCL_PREFIX} + eval TCL_EXEC_PREFIX=${TCL_EXEC_PREFIX} + eval TCL_LIB_FILE=${TCL_LIB_FILE} + # TCL_LIB_SPEC overrides TCL_LIBS as defined below + eval TCL_LIB_SPEC='${TCL_LIB_SPEC}' + +else + # check for tclsh in PATH (only if no --with-tcl given) + # Extract the first word of "tclsh", so it can be a program name with args. +set dummy tclsh; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:599: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_path_TCLSH'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + case "$TCLSH" in + /*) + ac_cv_path_TCLSH="$TCLSH" # Let the user override the test with a path. + ;; + ?:/*) + ac_cv_path_TCLSH="$TCLSH" # Let the user override the test with a dos path. + ;; + *) + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_path_TCLSH="$ac_dir/$ac_word" + break + fi + done + IFS="$ac_save_ifs" + ;; +esac +fi +TCLSH="$ac_cv_path_TCLSH" +if test -n "$TCLSH"; then + echo "$ac_t""$TCLSH" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + + if test -z "$TCLSH"; then + { echo "configure: error: Please specify --with-tcl (directory of tclConfig.sh)." 1>&2; exit 1; } + fi + echo $ac_n "checking "for tclsh version"""... $ac_c" 1>&6 +echo "configure:635: checking "for tclsh version"" >&5 + TCL_VERSION=`echo 'puts -nonewline $tcl_version' | $TCLSH` + echo "$ac_t"""$TCL_VERSION"" 1>&6 + if test -z "$TCL_VERSION"; then + { echo "configure: error: Require Tcl 8.0 or greater. Specify --with-tcl." 1>&2; exit 1; } + fi + TCL_MAJOR_VERSION=`echo 'scan $tcl_version %d.%d ma mi; puts -nonewline $ma' | $TCLSH` + TCL_MINOR_VERSION=`echo 'scan $tcl_version %d.%d ma mi; puts -nonewline $mi' | $TCLSH` + # guess Tcl prefix + TCL_PREFIX=`dirname ${TCLSH}` + TCL_PREFIX=`dirname ${TCL_PREFIX}` + TCL_EXEC_PREFIX=${TCL_PREFIX} + # guess Tcl library file + TCL_LIB_FILE=`ls ${TCL_EXEC_PREFIX}/lib/libtcl${TCL_MAJOR_VERSION}*.*` + TCL_LIB_FILE=`basename "${TCL_LIB_FILE}"` +fi + +if test $TCL_MAJOR_VERSION -lt 8; then + { echo "configure: error: "Require Tcl version 8.0 or greater."" 1>&2; exit 1; } +fi + +# ----------------------------------------------------------------------- +# Compiler and flags +# ----------------------------------------------------------------------- + +# Extract the first word of "gcc", so it can be a program name with args. +set dummy gcc; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:663: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_CC="gcc" + break + fi + done + IFS="$ac_save_ifs" +fi +fi +CC="$ac_cv_prog_CC" +if test -n "$CC"; then + echo "$ac_t""$CC" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + +if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:693: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_prog_rejected=no + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + if test "$ac_dir/$ac_word" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + break + fi + done + IFS="$ac_save_ifs" +if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# -gt 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + set dummy "$ac_dir/$ac_word" "$@" + shift + ac_cv_prog_CC="$@" + fi +fi +fi +fi +CC="$ac_cv_prog_CC" +if test -n "$CC"; then + echo "$ac_t""$CC" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + + if test -z "$CC"; then + case "`uname -s`" in + *win32* | *WIN32*) + # Extract the first word of "cl", so it can be a program name with args. +set dummy cl; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:744: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_CC="cl" + break + fi + done + IFS="$ac_save_ifs" +fi +fi +CC="$ac_cv_prog_CC" +if test -n "$CC"; then + echo "$ac_t""$CC" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + ;; + esac + fi + test -z "$CC" && { echo "configure: error: no acceptable cc found in \$PATH" 1>&2; exit 1; } +fi + +echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 +echo "configure:776: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 + +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross + +cat > conftest.$ac_ext << EOF + +#line 787 "configure" +#include "confdefs.h" + +main(){return(0);} +EOF +if { (eval echo configure:792: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + ac_cv_prog_cc_works=yes + # If we can't run a trivial program, we are probably using a cross compiler. + if (./conftest; exit) 2>/dev/null; then + ac_cv_prog_cc_cross=no + else + ac_cv_prog_cc_cross=yes + fi +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + ac_cv_prog_cc_works=no +fi +rm -fr conftest* +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross + +echo "$ac_t""$ac_cv_prog_cc_works" 1>&6 +if test $ac_cv_prog_cc_works = no; then + { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } +fi +echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 +echo "configure:818: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 +cross_compiling=$ac_cv_prog_cc_cross + +echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 +echo "configure:823: checking whether we are using GNU C" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.c <&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then + ac_cv_prog_gcc=yes +else + ac_cv_prog_gcc=no +fi +fi + +echo "$ac_t""$ac_cv_prog_gcc" 1>&6 + +if test $ac_cv_prog_gcc = yes; then + GCC=yes +else + GCC= +fi + +ac_test_CFLAGS="${CFLAGS+set}" +ac_save_CFLAGS="$CFLAGS" +CFLAGS= +echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 +echo "configure:851: checking whether ${CC-cc} accepts -g" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + echo 'void f(){}' > conftest.c +if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then + ac_cv_prog_cc_g=yes +else + ac_cv_prog_cc_g=no +fi +rm -f conftest* + +fi + +echo "$ac_t""$ac_cv_prog_cc_g" 1>&6 +if test "$ac_test_CFLAGS" = set; then + CFLAGS="$ac_save_CFLAGS" +elif test $ac_cv_prog_cc_g = yes; then + if test "$GCC" = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-g" + fi +else + if test "$GCC" = yes; then + CFLAGS="-O2" + else + CFLAGS= + fi +fi + +CFLAGS=-O2 +CXXFLAGS=-O2 +WFLAG="-W" +GFLAG="-g" +if test "$CC" = cl; then + CC="cl -nologo" + CXX=$CC + CXXFLAGS="-TP $CXXFLAGS" + WFLAG="-W3" + GFLAG="" +fi +for ac_prog in $CCC c++ g++ gcc CC cxx cc++ cl +do +# Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:898: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_CXX'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$CXX"; then + ac_cv_prog_CXX="$CXX" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_CXX="$ac_prog" + break + fi + done + IFS="$ac_save_ifs" +fi +fi +CXX="$ac_cv_prog_CXX" +if test -n "$CXX"; then + echo "$ac_t""$CXX" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + +test -n "$CXX" && break +done +test -n "$CXX" || CXX="gcc" + + +echo $ac_n "checking whether the C++ compiler ($CXX $CXXFLAGS $LDFLAGS) works""... $ac_c" 1>&6 +echo "configure:930: checking whether the C++ compiler ($CXX $CXXFLAGS $LDFLAGS) works" >&5 + +ac_ext=C +# CXXFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CXXCPP $CPPFLAGS' +ac_compile='${CXX-g++} -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CXX-g++} -o conftest${ac_exeext} $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cxx_cross + +cat > conftest.$ac_ext << EOF + +#line 941 "configure" +#include "confdefs.h" + +int main(){return(0);} +EOF +if { (eval echo configure:946: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + ac_cv_prog_cxx_works=yes + # If we can't run a trivial program, we are probably using a cross compiler. + if (./conftest; exit) 2>/dev/null; then + ac_cv_prog_cxx_cross=no + else + ac_cv_prog_cxx_cross=yes + fi +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + ac_cv_prog_cxx_works=no +fi +rm -fr conftest* +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross + +echo "$ac_t""$ac_cv_prog_cxx_works" 1>&6 +if test $ac_cv_prog_cxx_works = no; then + { echo "configure: error: installation or configuration problem: C++ compiler cannot create executables." 1>&2; exit 1; } +fi +echo $ac_n "checking whether the C++ compiler ($CXX $CXXFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 +echo "configure:972: checking whether the C++ compiler ($CXX $CXXFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "$ac_t""$ac_cv_prog_cxx_cross" 1>&6 +cross_compiling=$ac_cv_prog_cxx_cross + +echo $ac_n "checking whether we are using GNU C++""... $ac_c" 1>&6 +echo "configure:977: checking whether we are using GNU C++" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_gxx'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.C <&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then + ac_cv_prog_gxx=yes +else + ac_cv_prog_gxx=no +fi +fi + +echo "$ac_t""$ac_cv_prog_gxx" 1>&6 + +if test $ac_cv_prog_gxx = yes; then + GXX=yes +else + GXX= +fi + +ac_test_CXXFLAGS="${CXXFLAGS+set}" +ac_save_CXXFLAGS="$CXXFLAGS" +CXXFLAGS= +echo $ac_n "checking whether ${CXX-g++} accepts -g""... $ac_c" 1>&6 +echo "configure:1005: checking whether ${CXX-g++} accepts -g" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_cxx_g'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + echo 'void f(){}' > conftest.cc +if test -z "`${CXX-g++} -g -c conftest.cc 2>&1`"; then + ac_cv_prog_cxx_g=yes +else + ac_cv_prog_cxx_g=no +fi +rm -f conftest* + +fi + +echo "$ac_t""$ac_cv_prog_cxx_g" 1>&6 +if test "$ac_test_CXXFLAGS" = set; then + CXXFLAGS="$ac_save_CXXFLAGS" +elif test $ac_cv_prog_cxx_g = yes; then + if test "$GXX" = yes; then + CXXFLAGS="-g -O2" + else + CXXFLAGS="-g" + fi +else + if test "$GXX" = yes; then + CXXFLAGS="-O2" + else + CXXFLAGS= + fi +fi + + + + + +echo $ac_n "checking for u_int used by Meschach""... $ac_c" 1>&6 +echo "configure:1041: checking for u_int used by Meschach" >&5 +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross + +cat > conftest.$ac_ext < +int main() { + + u_int ui; + +; return 0; } +EOF +if { (eval echo configure:1059: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + have_u_int=yes +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + have_u_int=no +fi +rm -f conftest* +echo "$ac_t""${have_u_int}" 1>&6 +if test $have_u_int = yes; then + U_INT_DEF="-DU_INT_DEF=1" +else + U_INT_DEF="" +fi + + +if test "$GXX" = yes; then + echo $ac_n "checking for g++ compiler bug""... $ac_c" 1>&6 +echo "configure:1079: checking for g++ compiler bug" >&5 + ac_ext=C +# CXXFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CXXCPP $CPPFLAGS' +ac_compile='${CXX-g++} -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CXX-g++} -o conftest${ac_exeext} $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cxx_cross + + cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + gcc_bug=no +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + gcc_bug=yes +fi +rm -f conftest* + echo "$ac_t""${gcc_bug}" 1>&6 + if test $gcc_bug = yes; then + { echo "configure: error: "Your $CXX is buggy -- please install a newer version."" 1>&2; exit 1; } + fi +fi + +# ----------------------------------------------------------------------- +# Check for includes +# ----------------------------------------------------------------------- + +#AC_CHECK_HEADERS(ieeefp.h) + +# ----------------------------------------------------------------------- +# Linker, machine specific settings +# ----------------------------------------------------------------------- + +echo $ac_n "checking --disable-shared""... $ac_c" 1>&6 +echo "configure:1124: checking --disable-shared" >&5 +# Check whether --enable-shared or --disable-shared was given. +if test "${enable_shared+set}" = set; then + enableval="$enable_shared" + hqp_shared=$enableval +else + hqp_shared=yes +fi + +echo "$ac_t""$hqp_shared" 1>&6 + +# default configuration +PICFLAG="-fPIC" +OBJ_SUFFIX=".o" +LIB_PREFIX="lib" +LIB_SUFFIX=".so" +LDLIB_PREFIX="-l" +LDLIB_SUFFIX="" +EXE_SUFFIX="" +LD="$CC -shared -o " +LDFLAGS_START="" +LIB_SUFFIX=".so" +LFLAG="-L" +RFLAG="-Wl,-rpath," + +# Suffix used for making a library +# (will be set to LIB_SUFFIX if not specified differently) +MKLIB_SUFFIX="" + +# Tcl libraries +if test ! -z "$TCL_LIB_SPEC"; then + # take from tclConfig.sh + TCL_LIBS=$TCL_LIB_SPEC +else + TCL_LIBS="${LDLIB_PREFIX}tcl${TCL_VERSION}${LDLIB_SUFFIX}" +fi + +# Extract the first word of "uname", so it can be a program name with args. +set dummy uname; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:1164: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_uname_found'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$uname_found"; then + ac_cv_prog_uname_found="$uname_found" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_uname_found="yes" + break + fi + done + IFS="$ac_save_ifs" + test -z "$ac_cv_prog_uname_found" && ac_cv_prog_uname_found="no" +fi +fi +uname_found="$ac_cv_prog_uname_found" +if test -n "$uname_found"; then + echo "$ac_t""$uname_found" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + +if test $uname_found = "yes" ; then + if test "$CC" != "cl -nologo"; then + target=`uname -s` + else + target="CL" + fi + case "$target" in + Linux*) + if test "$hqp_shared" = "yes"; then + # guess Tcl libs if no tclConfig.sh available + if test -z "$TCL_LIB_SPEC"; then + echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6 +echo "configure:1203: checking for dlopen in -ldl" >&5 +ac_lib_var=`echo dl'_'dlopen | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-ldl $LIBS" +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then + echo "$ac_t""yes" 1>&6 + have_dl=yes +else + echo "$ac_t""no" 1>&6 +have_dl=no +fi + + if test $have_dl = "yes"; then + TCL_LIBS="$TCL_LIBS -ldl" + else + echo $ac_n "checking how to run the C++ preprocessor""... $ac_c" 1>&6 +echo "configure:1250: checking how to run the C++ preprocessor" >&5 +if test -z "$CXXCPP"; then +if eval "test \"`echo '$''{'ac_cv_prog_CXXCPP'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_ext=C +# CXXFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CXXCPP $CPPFLAGS' +ac_compile='${CXX-g++} -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CXX-g++} -o conftest${ac_exeext} $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cxx_cross + CXXCPP="${CXX-g++} -E" + cat > conftest.$ac_ext < +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:1268: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` +if test -z "$ac_err"; then + : +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + CXXCPP=/lib/cpp +fi +rm -f conftest* + ac_cv_prog_CXXCPP="$CXXCPP" +ac_ext=C +# CXXFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CXXCPP $CPPFLAGS' +ac_compile='${CXX-g++} -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CXX-g++} -o conftest${ac_exeext} $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cxx_cross +fi +fi +CXXCPP="$ac_cv_prog_CXXCPP" +echo "$ac_t""$CXXCPP" 1>&6 + +ac_safe=`echo "dld.h" | sed 'y%./+-%__p_%'` +echo $ac_n "checking for dld.h""... $ac_c" 1>&6 +echo "configure:1294: checking for dld.h" >&5 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:1304: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + + LD="ld -shared -o " + TCL_LIBS="$TCL_LIBS -ldld" +else + echo "$ac_t""no" 1>&6 +fi + + fi + fi + else + PICFLAG="" + LD="ar -cr " + LIB_SUFFIX=".a" + cat >> confdefs.h <<\EOF +#define IF_CLASS_STATIC 1 +EOF + + RFLAG="-L" + # Extract the first word of "ranlib", so it can be a program name with args. +set dummy ranlib; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:1341: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$RANLIB"; then + ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_RANLIB="ranlib" + break + fi + done + IFS="$ac_save_ifs" + test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":" +fi +fi +RANLIB="$ac_cv_prog_RANLIB" +if test -n "$RANLIB"; then + echo "$ac_t""$RANLIB" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + + fi + ;; + SunOS*) + RFLAG="-R" + ;; + OSF1*) + LD="$CC -shared -Wl,-expect_unresolved,\"*\" -o " + MES_CC="cc" + MES_CFLAGS="-O" + # no automatic concatenation of multiple rflags + RFLAG="-Wl,-rpath,../lib:" + ;; + IRIX*) + MES_CC="cc" + MES_CFLAGS="-O -KPIC" + ;; + HP-UX*) + PICFLAG="" + LD="ar -cr " + LIB_SUFFIX=".a" + cat >> confdefs.h <<\EOF +#define IF_CLASS_STATIC 1 +EOF + + RFLAG="-Wl,+b," + # Extract the first word of "ranlib", so it can be a program name with args. +set dummy ranlib; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:1396: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$RANLIB"; then + ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_RANLIB="ranlib" + break + fi + done + IFS="$ac_save_ifs" + test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":" +fi +fi +RANLIB="$ac_cv_prog_RANLIB" +if test -n "$RANLIB"; then + echo "$ac_t""$RANLIB" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + + ;; + CYGWIN*) + PICFLAG="" + LD="ar -cr " + LIB_SUFFIX=".a" + EXE_SUFFIX=".exe" + cat >> confdefs.h <<\EOF +#define IF_CLASS_STATIC 1 +EOF + + RFLAG="-L" + # Extract the first word of "ranlib", so it can be a program name with args. +set dummy ranlib; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:1437: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$RANLIB"; then + ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_RANLIB="ranlib" + break + fi + done + IFS="$ac_save_ifs" + test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":" +fi +fi +RANLIB="$ac_cv_prog_RANLIB" +if test -n "$RANLIB"; then + echo "$ac_t""$RANLIB" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + + ;; + CL) + if test "$hqp_shared" = "yes"; then + MKLIB_SUFFIX=".dll" + LD="link -dll -nologo -out:" + HQP_DEFS="$HQP_DEFS -DHQP_API=__declspec\(dllexport\)" + IF_DEFS="$IF_DEFS -DIF_API=__declspec\(dllexport\)" + cat >> confdefs.h <<\EOF +#define IF_CLASS_STATIC 1 +EOF + + else + LD="link -lib -nologo -out:" + fi + LDFLAGS_START="-link" + OBJ_SUFFIX=".obj" + LIB_PREFIX="" + LIB_SUFFIX=".lib" + LDLIB_PREFIX="" + LDLIB_SUFFIX=".lib" + EXE_SUFFIX=".exe" + PICFLAG="" + LFLAG="-LIBPATH:" + RFLAG="-LIBPATH:" + if test -z "$TCL_LIB_SPEC"; then + # take "." out of TCL_VERSION in case of no tclConfig.sh + TCL_VERSION="${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}" + TCL_LIBS="${LDLIB_PREFIX}tcl${TCL_VERSION}${LDLIB_SUFFIX}" + fi + ;; + esac +fi + + +CFLAGS="$CFLAGS $PICFLAG" +CXXFLAGS="$CXXFLAGS $PICFLAG" + +if test -z "$MKLIB_SUFFIX"; then + MKLIB_SUFFIX="$LIB_SUFFIX" +fi + +if test -z "$RANLIB"; then + RANLIB=":" +fi + +if test -z "$MES_CC"; then + MES_CC="$CC" + MES_CFLAGS="$CFLAGS" +fi + + + + + + + + + + + + + + + + + + +# ----------------------------------------------------------------------- +# Check for existence of install programs +# ----------------------------------------------------------------------- + +ac_aux_dir= +for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do + if test -f $ac_dir/install-sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install-sh -c" + break + elif test -f $ac_dir/install.sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install.sh -c" + break + fi +done +if test -z "$ac_aux_dir"; then + { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; } +fi +ac_config_guess=$ac_aux_dir/config.guess +ac_config_sub=$ac_aux_dir/config.sub +ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. + +# Find a good install program. We prefer a C program (faster), +# so one script is as good as another. But avoid the broken or +# incompatible versions: +# SysV /etc/install, /usr/sbin/install +# SunOS /usr/etc/install +# IRIX /sbin/install +# AIX /bin/install +# AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag +# AFS /usr/afsws/bin/install, which mishandles nonexistent args +# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" +# ./install, which can be erroneously created by make from ./install.sh. +echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 +echo "configure:1566: checking for a BSD compatible install" >&5 +if test -z "$INSTALL"; then +if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS=":" + for ac_dir in $PATH; do + # Account for people who put trailing slashes in PATH elements. + case "$ac_dir/" in + /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;; + *) + # OSF1 and SCO ODT 3.0 have their own names for install. + # Don't use installbsd from OSF since it installs stuff as root + # by default. + for ac_prog in ginstall scoinst install; do + if test -f $ac_dir/$ac_prog; then + if test $ac_prog = install && + grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then + # AIX install. It has an incompatible calling convention. + : + else + ac_cv_path_install="$ac_dir/$ac_prog -c" + break 2 + fi + fi + done + ;; + esac + done + IFS="$ac_save_IFS" + +fi + if test "${ac_cv_path_install+set}" = set; then + INSTALL="$ac_cv_path_install" + else + # As a last resort, use the slow shell script. We don't cache a + # path for INSTALL within a source directory, because that will + # break other packages using the cache if that directory is + # removed, or if the path is relative. + INSTALL="$ac_install_sh" + fi +fi +echo "$ac_t""$INSTALL" 1>&6 + +# Use test -z because SunOS4 sh mishandles braces in ${var-val}. +# It thinks the first close brace ends the variable substitution. +test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' + +test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}' + +test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' + + +# ----------------------------------------------------------------------- +# Check for location of Tcl includes and libraries +# ----------------------------------------------------------------------- + +# first try --with-tclinclude (as defined for TEA) + +echo $ac_n "checking --with-tclinclude""... $ac_c" 1>&6 +echo "configure:1626: checking --with-tclinclude" >&5 +# Check whether --with-tclinclude or --without-tclinclude was given. +if test "${with_tclinclude+set}" = set; then + withval="$with_tclinclude" + with_tclinclude=${withval} +fi + +echo "$ac_t"""$with_tclinclude"" 1>&6 + +echo $ac_n "checking for tcl.h""... $ac_c" 1>&6 +echo "configure:1636: checking for tcl.h" >&5 + +if test -z "${with_tclinclude}"; then + # guess standard location + with_tclinclude=${TCL_PREFIX}/include +fi + +if test -f ${with_tclinclude}/tcl.h; then + echo "$ac_t""${with_tclinclude}/tcl.h" 1>&6 + TCL_INCDIR="${with_tclinclude}" + +else + echo "$ac_t""file not found" 1>&6 + { echo "configure: error: Specify path of tcl.h via --with-tclinclude" 1>&2; exit 1; } +fi + +# Tcl lib + +echo $ac_n "checking for Tcl lib ${TCL_LIB_FILE}""... $ac_c" 1>&6 +echo "configure:1655: checking for Tcl lib ${TCL_LIB_FILE}" >&5 +with_tcllib=${TCL_EXEC_PREFIX}/lib +if test -f ${with_tcllib}/${TCL_LIB_FILE}; then + echo "$ac_t""${with_tcllib}/${TCL_LIB_FILE}" 1>&6 +else + echo "$ac_t""file not found" 1>&6 +fi +TCL_LIBDIR="$with_tcllib" + + +# Tcl lib is required for generating a DLL +HQP_MACH_OBJS="" +if test "$target" = CL; then + if test "$hqp_shared" = "yes"; then + HQP_MACH_OBJS="\$(TCL_LIBDIR) $TCL_LIBS" + fi +fi + + +# ----------------------------------------------------------------------- +# Configure DASPK and RKsuite if enabled +# ----------------------------------------------------------------------- + +# defaults to disable Fortran +OMU_DEFS="" +FORTRAN_COMP="" +FORTRAN_FLAGS="" +FORTRAN_LIBS="" + +# defaults to disable DASPK +OMU_INTDASPK_C="" +DASPK="" +DASPK_OBJS="" + +# defaults to disable RKsuite +OMU_INTRKSUITE_C="" +RKSUITE_O="" +RKSUITE_COMPILE_CMD="" + +echo $ac_n "checking --enable-fortran""... $ac_c" 1>&6 +echo "configure:1695: checking --enable-fortran" >&5 +# Check whether --enable-fortran or --disable-fortran was given. +if test "${enable_fortran+set}" = set; then + enableval="$enable_fortran" + omu_fortran=$enableval +else + omu_fortran=no +fi + +echo "$ac_t""$omu_fortran" 1>&6 + +if test "$omu_fortran" != no; then + # Extract the first word of "f77", so it can be a program name with args. +set dummy f77; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:1710: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_path_fortran_f77'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + case "$fortran_f77" in + /*) + ac_cv_path_fortran_f77="$fortran_f77" # Let the user override the test with a path. + ;; + ?:/*) + ac_cv_path_fortran_f77="$fortran_f77" # Let the user override the test with a dos path. + ;; + *) + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_path_fortran_f77="$ac_dir/$ac_word" + break + fi + done + IFS="$ac_save_ifs" + ;; +esac +fi +fortran_f77="$ac_cv_path_fortran_f77" +if test -n "$fortran_f77"; then + echo "$ac_t""$fortran_f77" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + + if test ! -z "$fortran_f77"; then + fortran_ftn="f77" + else + # Extract the first word of "g77", so it can be a program name with args. +set dummy g77; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:1748: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_path_fortran_g77'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + case "$fortran_g77" in + /*) + ac_cv_path_fortran_g77="$fortran_g77" # Let the user override the test with a path. + ;; + ?:/*) + ac_cv_path_fortran_g77="$fortran_g77" # Let the user override the test with a dos path. + ;; + *) + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_path_fortran_g77="$ac_dir/$ac_word" + break + fi + done + IFS="$ac_save_ifs" + ;; +esac +fi +fortran_g77="$ac_cv_path_fortran_g77" +if test -n "$fortran_g77"; then + echo "$ac_t""$fortran_g77" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + + if test ! -z "$fortran_g77"; then + fortran_ftn="g77" + else + { echo "configure: error: "Require f77 or g77 to enable RKsuite."" 1>&2; exit 1; } + fi + fi + + # default settings to enable Fortran + # (MES_CFLAGS are assumed to be valid for machine Fortran) + OMU_DEFS="-DOMU_WITH_FORTRAN=1" + FORTRAN_COMP="${fortran_ftn}" + FORTRAN_FLAGS="${MES_CFLAGS}" + + # default settings for DASPK + OMU_INTDASPK_C="Omu_IntDASPK.C" + DASPK="daspk" + DASPK_OBJS="../daspk/solver/*.o ../daspk/preconds/*.o" + + # default settings with RKsuite + OMU_INTRKSUITE_C="Omu_IntRKsuite.C" + RKSUITE_O="`pwd`/rksuite/rksuite.o" + + # try to figure out Fortran environment + echo $ac_n "checking for pow_dd in -lf2c""... $ac_c" 1>&6 +echo "configure:1804: checking for pow_dd in -lf2c" >&5 +ac_lib_var=`echo f2c'_'pow_dd | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lf2c $LIBS" +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then + echo "$ac_t""yes" 1>&6 + fortran_lib=f2c +else + echo "$ac_t""no" 1>&6 +fortran_lib="" +fi + + echo $ac_n "checking for pow_dd in -lg2c""... $ac_c" 1>&6 +echo "configure:1848: checking for pow_dd in -lg2c" >&5 +ac_lib_var=`echo g2c'_'pow_dd | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lg2c $LIBS" +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then + echo "$ac_t""yes" 1>&6 + fortran_lib=g2c +else + echo "$ac_t""no" 1>&6 +fi + + if test "${fortran_f77}" = "f77"; then + echo $ac_n "checking for pow_dd in -lftn""... $ac_c" 1>&6 +echo "configure:1892: checking for pow_dd in -lftn" >&5 +ac_lib_var=`echo ftn'_'pow_dd | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lftn $LIBS" +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then + echo "$ac_t""yes" 1>&6 + fortran_lib=ftn +else + echo "$ac_t""no" 1>&6 +fi + + fi + + case "$fortran_lib" in + ftn) + FORTRAN_LIBS="-lftn" + ;; + g2c) +# don't use g2c.h due to name clash with ADOL-C (symbol "address") +# AC_CHECK_HEADER(g2c.h, OMU_DEFS="$OMU_DEFS -DHAVE_G2C_H=1") + FORTRAN_LIBS="-lg2c" + ;; + f2c) +# don't use f2c.h due to name clash with ADOL-C (symbol "address") +# AC_CHECK_HEADER(f2c.h, OMU_DEFS="$OMU_DEFS -DHAVE_F2C_H=1") + FORTRAN_LIBS="-lf2c" + ;; + esac +fi + +if test "$RKSUITE_O" != ""; then + echo "$ac_t"""enabling DASPK and RKsuite"" 1>&6 +fi + + + + + + + + + + + + + +# ----------------------------------------------------------------------- +# Configure GNU malloc if enabled or if system malloc is buggy +# ----------------------------------------------------------------------- + +# defaults to disable GNU malloc +GMALLOC_O="" + +echo $ac_n "checking --enable_gmalloc""... $ac_c" 1>&6 +echo "configure:1977: checking --enable_gmalloc" >&5 +# Check whether --enable-gmalloc or --disable-gmalloc was given. +if test "${enable_gmalloc+set}" = set; then + enableval="$enable_gmalloc" + odc_gmalloc=$enableval +else + odc_gmalloc=no +fi + +echo "$ac_t""$odc_gmalloc" 1>&6 + +if test "$odc_gmalloc" = no; then + echo $ac_n "checking "for malloc bug"""... $ac_c" 1>&6 +echo "configure:1990: checking "for malloc bug"" >&5 + ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross + + if test "$cross_compiling" = yes; then + odc_gmalloc=yes +else + cat > conftest.$ac_ext < + int main() + { + if (malloc(0) == NULL) + return 1; + return 0; + } + +EOF +if { (eval echo configure:2014: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +then + odc_gmalloc=no +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -fr conftest* + odc_gmalloc=yes +fi +rm -fr conftest* +fi + + echo "$ac_t"""$odc_gmalloc"" 1>&6 +fi +if test "$odc_gmalloc" != no; then + GMALLOC_O="`pwd`/malloc/gmalloc.o" +fi + +if test "$GMALLOC_O" != ""; then + echo "$ac_t"""enabling GNU malloc"" 1>&6 +fi + + + +# ----------------------------------------------------------------------- +# Configure support for CUTE +# ----------------------------------------------------------------------- + +echo $ac_n "checking --enable_cute""... $ac_c" 1>&6 +echo "configure:2043: checking --enable_cute" >&5 +# Check whether --enable-cute or --disable-cute was given. +if test "${enable_cute+set}" = set; then + enableval="$enable_cute" + hqp_cute=$enableval +else + hqp_cute=no +fi + +echo "$ac_t""$hqp_cute" 1>&6 + +if test "$hqp_cute" != no; then + CUTE_SRCS="Hqp_CUTE_stubs_.C Hqp_CUTE_dummies.C Prg_CUTE.C Prg_CUTE_ST.C Hqp_CUTE.C" + HQP_DEFS="$HQP_DEFS -DHQP_WITH_CUTE=1" +else + CUTE_SRCS="" +fi + + + +# ----------------------------------------------------------------------- +# Configure support for Ascend +# ----------------------------------------------------------------------- + +echo $ac_n "checking --enable_ascend""... $ac_c" 1>&6 +echo "configure:2068: checking --enable_ascend" >&5 +# Check whether --enable-ascend or --disable-ascend was given. +if test "${enable_ascend+set}" = set; then + enableval="$enable_ascend" + hqp_ascend=$enableval +else + hqp_ascend=no +fi + +echo "$ac_t""$hqp_ascend" 1>&6 + +if test "$hqp_ascend" != no; then + ASCEND_INCDIR="-I../../ascend4" + ASCEND_SRCS="Hqp_ASCEND_dummies.C Prg_ASCEND.C" + HQP_DEFS="$HQP_DEFS -DHQP_WITH_ASCEND=1" +else + ASCEND_INCDIR="" + ASCEND_SRCS="" +fi + + + + + + +# ----------------------------------------------------------------------- +# Produce outputs +# ----------------------------------------------------------------------- + +trap '' 1 2 15 +cat > confcache <<\EOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs. It is not useful on other systems. +# If it contains results you don't want to keep, you may remove or edit it. +# +# By default, configure uses ./config.cache as the cache file, +# creating it if it does not exist already. You can give configure +# the --cache-file=FILE option to use a different cache file; that is +# what configure does when it calls configure scripts in +# subdirectories, so they share the cache. +# Giving --cache-file=/dev/null disables caching, for debugging configure. +# config.status only pays attention to the cache file if you give it the +# --recheck option to rerun configure. +# +EOF +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, don't put newlines in cache variables' values. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +(set) 2>&1 | + case `(ac_space=' '; set | grep ac_space) 2>&1` in + *ac_space=\ *) + # `set' does not quote correctly, so add quotes (double-quote substitution + # turns \\\\ into \\, and sed turns \\ into \). + sed -n \ + -e "s/'/'\\\\''/g" \ + -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p" + ;; + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p' + ;; + esac >> confcache +if cmp -s $cache_file confcache; then + : +else + if test -w $cache_file; then + echo "updating cache $cache_file" + cat confcache > $cache_file + else + echo "not updating unwritable cache $cache_file" + fi +fi +rm -f confcache + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# Any assignment to VPATH causes Sun make to only execute +# the first set of double-colon rules, so remove it if not needed. +# If there is a colon in the path, we need to keep it. +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' +fi + +trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 + +# Transform confdefs.h into DEFS. +# Protect against shell expansion while executing Makefile rules. +# Protect against Makefile macro expansion. +cat > conftest.defs <<\EOF +s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g +s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g +s%\[%\\&%g +s%\]%\\&%g +s%\$%$$%g +EOF +DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '` +rm -f conftest.defs + + +# Without the "./", some shells look in PATH for config.status. +: ${CONFIG_STATUS=./config.status} + +echo creating $CONFIG_STATUS +rm -f $CONFIG_STATUS +cat > $CONFIG_STATUS </dev/null | sed 1q`: +# +# $0 $ac_configure_args +# +# Compiler output produced by configure, useful for debugging +# configure, is in ./config.log if it exists. + +ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" +for ac_option +do + case "\$ac_option" in + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" + exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; + -version | --version | --versio | --versi | --vers | --ver | --ve | --v) + echo "$CONFIG_STATUS generated by autoconf version 2.13" + exit 0 ;; + -help | --help | --hel | --he | --h) + echo "\$ac_cs_usage"; exit 0 ;; + *) echo "\$ac_cs_usage"; exit 1 ;; + esac +done + +ac_given_srcdir=$srcdir +ac_given_INSTALL="$INSTALL" + +trap 'rm -fr `echo "makedefs makedirs odc/Makefile hqp_docp/Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 +EOF +cat >> $CONFIG_STATUS < conftest.subs <<\\CEOF +$ac_vpsub +$extrasub +s%@SHELL@%$SHELL%g +s%@CFLAGS@%$CFLAGS%g +s%@CPPFLAGS@%$CPPFLAGS%g +s%@CXXFLAGS@%$CXXFLAGS%g +s%@FFLAGS@%$FFLAGS%g +s%@DEFS@%$DEFS%g +s%@LDFLAGS@%$LDFLAGS%g +s%@LIBS@%$LIBS%g +s%@exec_prefix@%$exec_prefix%g +s%@prefix@%$prefix%g +s%@program_transform_name@%$program_transform_name%g +s%@bindir@%$bindir%g +s%@sbindir@%$sbindir%g +s%@libexecdir@%$libexecdir%g +s%@datadir@%$datadir%g +s%@sysconfdir@%$sysconfdir%g +s%@sharedstatedir@%$sharedstatedir%g +s%@localstatedir@%$localstatedir%g +s%@libdir@%$libdir%g +s%@includedir@%$includedir%g +s%@oldincludedir@%$oldincludedir%g +s%@infodir@%$infodir%g +s%@mandir@%$mandir%g +s%@TCLSH@%$TCLSH%g +s%@CC@%$CC%g +s%@CXX@%$CXX%g +s%@WFLAG@%$WFLAG%g +s%@GFLAG@%$GFLAG%g +s%@U_INT_DEF@%$U_INT_DEF%g +s%@uname_found@%$uname_found%g +s%@CXXCPP@%$CXXCPP%g +s%@RANLIB@%$RANLIB%g +s%@OBJ_SUFFIX@%$OBJ_SUFFIX%g +s%@LIB_PREFIX@%$LIB_PREFIX%g +s%@LIB_SUFFIX@%$LIB_SUFFIX%g +s%@MKLIB_SUFFIX@%$MKLIB_SUFFIX%g +s%@LDLIB_PREFIX@%$LDLIB_PREFIX%g +s%@LDLIB_SUFFIX@%$LDLIB_SUFFIX%g +s%@EXE_SUFFIX@%$EXE_SUFFIX%g +s%@LD@%$LD%g +s%@LDFLAGS_START@%$LDFLAGS_START%g +s%@LFLAG@%$LFLAG%g +s%@RFLAG@%$RFLAG%g +s%@TCL_LIBS@%$TCL_LIBS%g +s%@MES_CC@%$MES_CC%g +s%@MES_CFLAGS@%$MES_CFLAGS%g +s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g +s%@INSTALL_SCRIPT@%$INSTALL_SCRIPT%g +s%@INSTALL_DATA@%$INSTALL_DATA%g +s%@TCL_INCDIR@%$TCL_INCDIR%g +s%@TCL_LIBDIR@%$TCL_LIBDIR%g +s%@HQP_MACH_OBJS@%$HQP_MACH_OBJS%g +s%@fortran_f77@%$fortran_f77%g +s%@fortran_g77@%$fortran_g77%g +s%@OMU_DEFS@%$OMU_DEFS%g +s%@FORTRAN_COMP@%$FORTRAN_COMP%g +s%@FORTRAN_FLAGS@%$FORTRAN_FLAGS%g +s%@FORTRAN_LIBS@%$FORTRAN_LIBS%g +s%@OMU_INTDASPK_C@%$OMU_INTDASPK_C%g +s%@DASPK@%$DASPK%g +s%@DASPK_OBJS@%$DASPK_OBJS%g +s%@OMU_INTRKSUITE_C@%$OMU_INTRKSUITE_C%g +s%@RKSUITE_O@%$RKSUITE_O%g +s%@GMALLOC_O@%$GMALLOC_O%g +s%@CUTE_SRCS@%$CUTE_SRCS%g +s%@ASCEND_INCDIR@%$ASCEND_INCDIR%g +s%@ASCEND_SRCS@%$ASCEND_SRCS%g +s%@HQP_DEFS@%$HQP_DEFS%g +s%@IF_DEFS@%$IF_DEFS%g + +CEOF +EOF + +cat >> $CONFIG_STATUS <<\EOF + +# Split the substitutions into bite-sized pieces for seds with +# small command number limits, like on Digital OSF/1 and HP-UX. +ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script. +ac_file=1 # Number of current file. +ac_beg=1 # First line for current file. +ac_end=$ac_max_sed_cmds # Line after last line for current file. +ac_more_lines=: +ac_sed_cmds="" +while $ac_more_lines; do + if test $ac_beg -gt 1; then + sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file + else + sed "${ac_end}q" conftest.subs > conftest.s$ac_file + fi + if test ! -s conftest.s$ac_file; then + ac_more_lines=false + rm -f conftest.s$ac_file + else + if test -z "$ac_sed_cmds"; then + ac_sed_cmds="sed -f conftest.s$ac_file" + else + ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file" + fi + ac_file=`expr $ac_file + 1` + ac_beg=$ac_end + ac_end=`expr $ac_end + $ac_max_sed_cmds` + fi +done +if test -z "$ac_sed_cmds"; then + ac_sed_cmds=cat +fi +EOF + +cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF +for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then + # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". + case "$ac_file" in + *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` + ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; + *) ac_file_in="${ac_file}.in" ;; + esac + + # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories. + + # Remove last slash and all that follows it. Not all systems have dirname. + ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` + if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then + # The file is in a subdirectory. + test ! -d "$ac_dir" && mkdir "$ac_dir" + ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" + # A "../" for each directory in $ac_dir_suffix. + ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` + else + ac_dir_suffix= ac_dots= + fi + + case "$ac_given_srcdir" in + .) srcdir=. + if test -z "$ac_dots"; then top_srcdir=. + else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; + /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; + *) # Relative path. + srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" + top_srcdir="$ac_dots$ac_given_srcdir" ;; + esac + + case "$ac_given_INSTALL" in + [/$]*) INSTALL="$ac_given_INSTALL" ;; + *) INSTALL="$ac_dots$ac_given_INSTALL" ;; + esac + + echo creating "$ac_file" + rm -f "$ac_file" + configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." + case "$ac_file" in + *Makefile*) ac_comsub="1i\\ +# $configure_input" ;; + *) ac_comsub= ;; + esac + + ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` + sed -e "$ac_comsub +s%@configure_input@%$configure_input%g +s%@srcdir@%$srcdir%g +s%@top_srcdir@%$top_srcdir%g +s%@INSTALL@%$INSTALL%g +" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file +fi; done +rm -f conftest.s* + +EOF +cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF + +exit 0 +EOF +chmod +x $CONFIG_STATUS +rm -fr confdefs* $ac_clean_files +test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 + diff --git a/configure.in b/configure.in new file mode 100644 index 0000000..30d3504 --- /dev/null +++ b/configure.in @@ -0,0 +1,524 @@ +dnl Process this file with the GNU "autoconf" to produce a configure script +dnl for HQP/Omuses + +AC_INIT(hqp/Hqp.h) + +MAJOR_VERSION=1 +MINOR_VERSION=7 +PATCHLEVEL=b1 + +VERSION=${MAJOR_VERSION}.${MINOR_VERSION}${PATCHLEVEL} + +AC_DEFINE_UNQUOTED(VERSION, "${VERSION}") + +# collect HQP defines +HQP_DEFS="" + +# collect IF defines +IF_DEFS="" + +# ----------------------------------------------------------------------- +# Check for Tcl 8 +# ----------------------------------------------------------------------- + +# first try --with-tcl (as defined for TEA) + +AC_MSG_CHECKING([--with-tcl]) +AC_ARG_WITH(tcl, + [ --with-tcl directory containing tcl configuration (tclConfig.sh)], + [with_tcl=$withval]) +AC_MSG_RESULT("$with_tcl") + +if test ! -z "${with_tcl}"; then + AC_MSG_CHECKING([for existence of ${with_tcl}/tclConfig.sh]) + if test -f "${with_tcl}/tclConfig.sh" ; then + AC_MSG_RESULT([loading]) + . ${with_tcl}/tclConfig.sh + else + AC_MSG_RESULT([file not found]) + AC_MSG_ERROR([wrong --with-tcl specification]) + fi + # apply eval to vars used from tclConfig.h + # (this documents and it is partly required for substituitions) + eval TCL_VERSION=${TCL_VERSION} + eval TCL_MAJOR_VERSION=${TCL_MAJOR_VERSION} + eval TCL_MINOR_VERSION=${TCL_MINOR_VERSION} + eval TCL_PREFIX=${TCL_PREFIX} + eval TCL_EXEC_PREFIX=${TCL_EXEC_PREFIX} + eval TCL_LIB_FILE=${TCL_LIB_FILE} + # TCL_LIB_SPEC overrides TCL_LIBS as defined below + eval TCL_LIB_SPEC='${TCL_LIB_SPEC}' + +else + # check for tclsh in PATH (only if no --with-tcl given) + AC_PATH_PROG(TCLSH, tclsh) + if test -z "$TCLSH"; then + AC_MSG_ERROR([Please specify --with-tcl (directory of tclConfig.sh).]) + fi + AC_MSG_CHECKING("for tclsh version") + TCL_VERSION=`echo 'puts -nonewline $tcl_version' | $TCLSH` + AC_MSG_RESULT("$TCL_VERSION") + if test -z "$TCL_VERSION"; then + AC_MSG_ERROR([Require Tcl 8.0 or greater. Specify --with-tcl.]) + fi + TCL_MAJOR_VERSION=`echo 'scan $tcl_version %d.%d ma mi; puts -nonewline $ma' | $TCLSH` + TCL_MINOR_VERSION=`echo 'scan $tcl_version %d.%d ma mi; puts -nonewline $mi' | $TCLSH` + # guess Tcl prefix + TCL_PREFIX=`dirname ${TCLSH}` + TCL_PREFIX=`dirname ${TCL_PREFIX}` + TCL_EXEC_PREFIX=${TCL_PREFIX} + # guess Tcl library file + TCL_LIB_FILE=`ls ${TCL_EXEC_PREFIX}/lib/libtcl${TCL_MAJOR_VERSION}*.*` + TCL_LIB_FILE=`basename "${TCL_LIB_FILE}"` +fi + +if test $TCL_MAJOR_VERSION -lt 8; then + AC_MSG_ERROR("Require Tcl version 8.0 or greater.") +fi + +# ----------------------------------------------------------------------- +# Compiler and flags +# ----------------------------------------------------------------------- + +AC_PROG_CC +CFLAGS=-O2 +CXXFLAGS=-O2 +WFLAG="-W" +GFLAG="-g" +if test "$CC" = cl; then + CC="cl -nologo" + CXX=$CC + CXXFLAGS="-TP $CXXFLAGS" + WFLAG="-W3" + GFLAG="" +fi +AC_PROG_CXX + +AC_SUBST(WFLAG) +AC_SUBST(GFLAG) + +AC_MSG_CHECKING([for u_int used by Meschach]) +AC_LANG_C +AC_TRY_COMPILE([#include ], [ + u_int ui; + ], have_u_int=yes, have_u_int=no) +AC_MSG_RESULT(${have_u_int}) +if test $have_u_int = yes; then + U_INT_DEF="-DU_INT_DEF=1" +else + U_INT_DEF="" +fi +AC_SUBST(U_INT_DEF) + +if test "$GXX" = yes; then + AC_MSG_CHECKING([for g++ compiler bug]) + AC_LANG_CPLUSPLUS + AC_TRY_COMPILE(, [ + class A { void realloc(); void mymethod() { realloc(); } }; + ], gcc_bug=no, gcc_bug=yes) + AC_MSG_RESULT(${gcc_bug}) + if test $gcc_bug = yes; then + AC_MSG_ERROR("Your $CXX is buggy -- please install a newer version.") + fi +fi + +# ----------------------------------------------------------------------- +# Check for includes +# ----------------------------------------------------------------------- + +#AC_CHECK_HEADERS(ieeefp.h) + +# ----------------------------------------------------------------------- +# Linker, machine specific settings +# ----------------------------------------------------------------------- + +AC_MSG_CHECKING([--disable-shared]) +AC_ARG_ENABLE(shared, + [ --disable-shared disable dynamic loading of HQP/Omuses], + [hqp_shared=$enableval], [hqp_shared=yes]) +AC_MSG_RESULT($hqp_shared) + +# default configuration +PICFLAG="-fPIC" +OBJ_SUFFIX=".o" +LIB_PREFIX="lib" +LIB_SUFFIX=".so" +LDLIB_PREFIX="-l" +LDLIB_SUFFIX="" +EXE_SUFFIX="" +LD="$CC -shared -o " +LDFLAGS_START="" +LIB_SUFFIX=".so" +LFLAG="-L" +RFLAG="-Wl,-rpath," + +# Suffix used for making a library +# (will be set to LIB_SUFFIX if not specified differently) +MKLIB_SUFFIX="" + +# Tcl libraries +if test ! -z "$TCL_LIB_SPEC"; then + # take from tclConfig.sh + TCL_LIBS=$TCL_LIB_SPEC +else + TCL_LIBS="${LDLIB_PREFIX}tcl${TCL_VERSION}${LDLIB_SUFFIX}" +fi + +AC_PROGRAM_CHECK(uname_found, uname, yes, no) +if test $uname_found = "yes" ; then + if test "$CC" != "cl -nologo"; then + target=`uname -s` + else + target="CL" + fi + case "$target" in + Linux*) + if test "$hqp_shared" = "yes"; then + # guess Tcl libs if no tclConfig.sh available + if test -z "$TCL_LIB_SPEC"; then + AC_CHECK_LIB(dl, dlopen, have_dl=yes, have_dl=no) + if test $have_dl = "yes"; then + TCL_LIBS="$TCL_LIBS -ldl" + else + AC_CHECK_HEADER(dld.h, [ + LD="ld -shared -o " + TCL_LIBS="$TCL_LIBS -ldld"]) + fi + fi + else + PICFLAG="" + LD="ar -cr " + LIB_SUFFIX=".a" + AC_DEFINE(IF_CLASS_STATIC) + RFLAG="-L" + AC_PROG_RANLIB + fi + ;; + SunOS*) + RFLAG="-R" + ;; + OSF1*) + LD="$CC -shared -Wl,-expect_unresolved,\"*\" -o " + MES_CC="cc" + MES_CFLAGS="-O" + # no automatic concatenation of multiple rflags + RFLAG="-Wl,-rpath,../lib:" + ;; + IRIX*) + MES_CC="cc" + MES_CFLAGS="-O -KPIC" + ;; + HP-UX*) + PICFLAG="" + LD="ar -cr " + LIB_SUFFIX=".a" + AC_DEFINE(IF_CLASS_STATIC) + RFLAG="-Wl,+b," + AC_PROG_RANLIB + ;; + CYGWIN*) + PICFLAG="" + LD="ar -cr " + LIB_SUFFIX=".a" + EXE_SUFFIX=".exe" + AC_DEFINE(IF_CLASS_STATIC) + RFLAG="-L" + AC_PROG_RANLIB + ;; + CL) + if test "$hqp_shared" = "yes"; then + MKLIB_SUFFIX=".dll" + LD="link -dll -nologo -out:" + HQP_DEFS="$HQP_DEFS -DHQP_API=__declspec\(dllexport\)" + IF_DEFS="$IF_DEFS -DIF_API=__declspec\(dllexport\)" + AC_DEFINE(IF_CLASS_STATIC) + else + LD="link -lib -nologo -out:" + fi + LDFLAGS_START="-link" + OBJ_SUFFIX=".obj" + LIB_PREFIX="" + LIB_SUFFIX=".lib" + LDLIB_PREFIX="" + LDLIB_SUFFIX=".lib" + EXE_SUFFIX=".exe" + PICFLAG="" + LFLAG="-LIBPATH:" + RFLAG="-LIBPATH:" + if test -z "$TCL_LIB_SPEC"; then + # take "." out of TCL_VERSION in case of no tclConfig.sh + TCL_VERSION="${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}" + TCL_LIBS="${LDLIB_PREFIX}tcl${TCL_VERSION}${LDLIB_SUFFIX}" + fi + ;; + esac +fi + + +CFLAGS="$CFLAGS $PICFLAG" +CXXFLAGS="$CXXFLAGS $PICFLAG" + +if test -z "$MKLIB_SUFFIX"; then + MKLIB_SUFFIX="$LIB_SUFFIX" +fi + +if test -z "$RANLIB"; then + RANLIB=":" +fi + +if test -z "$MES_CC"; then + MES_CC="$CC" + MES_CFLAGS="$CFLAGS" +fi + +AC_SUBST(OBJ_SUFFIX) +AC_SUBST(LIB_PREFIX) +AC_SUBST(LIB_SUFFIX) +AC_SUBST(MKLIB_SUFFIX) +AC_SUBST(LDLIB_PREFIX) +AC_SUBST(LDLIB_SUFFIX) +AC_SUBST(EXE_SUFFIX) +AC_SUBST(LD) +AC_SUBST(LDFLAGS_START) +AC_SUBST(LFLAG) +AC_SUBST(RFLAG) +AC_SUBST(TCL_LIBS) +AC_SUBST(RANLIB) + +AC_SUBST(MES_CC) +AC_SUBST(MES_CFLAGS) + +# ----------------------------------------------------------------------- +# Check for existence of install programs +# ----------------------------------------------------------------------- + +AC_PROG_INSTALL + +# ----------------------------------------------------------------------- +# Check for location of Tcl includes and libraries +# ----------------------------------------------------------------------- + +# first try --with-tclinclude (as defined for TEA) + +AC_MSG_CHECKING([--with-tclinclude]) +AC_ARG_WITH(tclinclude, + [ --with-tclinclude directory containing include file tcl.h], + [with_tclinclude=${withval}]) +AC_MSG_RESULT("$with_tclinclude") + +AC_MSG_CHECKING([for tcl.h]) + +if test -z "${with_tclinclude}"; then + # guess standard location + with_tclinclude=${TCL_PREFIX}/include +fi + +if test -f ${with_tclinclude}/tcl.h; then + AC_MSG_RESULT([${with_tclinclude}/tcl.h]) + TCL_INCDIR="${with_tclinclude}" + AC_SUBST(TCL_INCDIR) +else + AC_MSG_RESULT([file not found]) + AC_MSG_ERROR([Specify path of tcl.h via --with-tclinclude]) +fi + +# Tcl lib + +AC_MSG_CHECKING([for Tcl lib ${TCL_LIB_FILE}]) +with_tcllib=${TCL_EXEC_PREFIX}/lib +if test -f ${with_tcllib}/${TCL_LIB_FILE}; then + AC_MSG_RESULT([${with_tcllib}/${TCL_LIB_FILE}]) +else + AC_MSG_RESULT([file not found]) +fi +TCL_LIBDIR="$with_tcllib" +AC_SUBST(TCL_LIBDIR) + +# Tcl lib is required for generating a DLL +HQP_MACH_OBJS="" +if test "$target" = CL; then + if test "$hqp_shared" = "yes"; then + HQP_MACH_OBJS="\$(TCL_LIBDIR) $TCL_LIBS" + fi +fi +AC_SUBST(HQP_MACH_OBJS) + +# ----------------------------------------------------------------------- +# Configure DASPK and RKsuite if enabled +# ----------------------------------------------------------------------- + +# defaults to disable Fortran +OMU_DEFS="" +FORTRAN_COMP="" +FORTRAN_FLAGS="" +FORTRAN_LIBS="" + +# defaults to disable DASPK +OMU_INTDASPK_C="" +DASPK="" +DASPK_OBJS="" + +# defaults to disable RKsuite +OMU_INTRKSUITE_C="" +RKSUITE_O="" +RKSUITE_COMPILE_CMD="" + +AC_MSG_CHECKING([--enable-fortran]) +AC_ARG_ENABLE(fortran, + [ --enable-fortran include DASPK and RKsuite with Omuses], + [omu_fortran=$enableval], [omu_fortran=no]) +AC_MSG_RESULT($omu_fortran) + +if test "$omu_fortran" != no; then + AC_PATH_PROG(fortran_f77, f77) + if test ! -z "$fortran_f77"; then + fortran_ftn="f77" + else + AC_PATH_PROG(fortran_g77, g77) + if test ! -z "$fortran_g77"; then + fortran_ftn="g77" + else + AC_MSG_ERROR("Require f77 or g77 to enable RKsuite.") + fi + fi + + # default settings to enable Fortran + # (MES_CFLAGS are assumed to be valid for machine Fortran) + OMU_DEFS="-DOMU_WITH_FORTRAN=1" + FORTRAN_COMP="${fortran_ftn}" + FORTRAN_FLAGS="${MES_CFLAGS}" + + # default settings for DASPK + OMU_INTDASPK_C="Omu_IntDASPK.C" + DASPK="daspk" + DASPK_OBJS="../daspk/solver/*.o ../daspk/preconds/*.o" + + # default settings with RKsuite + OMU_INTRKSUITE_C="Omu_IntRKsuite.C" + RKSUITE_O="`pwd`/rksuite/rksuite.o" + + # try to figure out Fortran environment + AC_CHECK_LIB(f2c, pow_dd, fortran_lib=f2c, fortran_lib="") + AC_CHECK_LIB(g2c, pow_dd, fortran_lib=g2c) + if test "${fortran_f77}" = "f77"; then + AC_CHECK_LIB(ftn, pow_dd, fortran_lib=ftn) + fi + + case "$fortran_lib" in + ftn) + FORTRAN_LIBS="-lftn" + ;; + g2c) +# don't use g2c.h due to name clash with ADOL-C (symbol "address") +# AC_CHECK_HEADER(g2c.h, OMU_DEFS="$OMU_DEFS -DHAVE_G2C_H=1") + FORTRAN_LIBS="-lg2c" + ;; + f2c) +# don't use f2c.h due to name clash with ADOL-C (symbol "address") +# AC_CHECK_HEADER(f2c.h, OMU_DEFS="$OMU_DEFS -DHAVE_F2C_H=1") + FORTRAN_LIBS="-lf2c" + ;; + esac +fi + +if test "$RKSUITE_O" != ""; then + AC_MSG_RESULT("enabling DASPK and RKsuite") +fi + +AC_SUBST(OMU_DEFS) +AC_SUBST(FORTRAN_COMP) +AC_SUBST(FORTRAN_FLAGS) +AC_SUBST(FORTRAN_LIBS) + +AC_SUBST(OMU_INTDASPK_C) +AC_SUBST(DASPK) +AC_SUBST(DASPK_OBJS) + +AC_SUBST(OMU_INTRKSUITE_C) +AC_SUBST(RKSUITE_O) + +# ----------------------------------------------------------------------- +# Configure GNU malloc if enabled or if system malloc is buggy +# ----------------------------------------------------------------------- + +# defaults to disable GNU malloc +GMALLOC_O="" + +AC_MSG_CHECKING([--enable_gmalloc]) +AC_ARG_ENABLE(gmalloc, + [ --enable-gmalloc link ODC with GNU malloc], + [odc_gmalloc=$enableval], [odc_gmalloc=no]) +AC_MSG_RESULT($odc_gmalloc) + +if test "$odc_gmalloc" = no; then + AC_MSG_CHECKING("for malloc bug") + AC_LANG_C + AC_TRY_RUN([ + #include + int main() + { + if (malloc(0) == NULL) + return 1; + return 0; + } + ], odc_gmalloc=no, odc_gmalloc=yes, odc_gmalloc=yes) + AC_MSG_RESULT("$odc_gmalloc") +fi +if test "$odc_gmalloc" != no; then + GMALLOC_O="`pwd`/malloc/gmalloc.o" +fi + +if test "$GMALLOC_O" != ""; then + AC_MSG_RESULT("enabling GNU malloc") +fi + +AC_SUBST(GMALLOC_O) + +# ----------------------------------------------------------------------- +# Configure support for CUTE +# ----------------------------------------------------------------------- + +AC_MSG_CHECKING([--enable_cute]) +AC_ARG_ENABLE(cute, + [ --enable-cute include CUTE interface with HQP], + [hqp_cute=$enableval], [hqp_cute=no]) +AC_MSG_RESULT($hqp_cute) + +if test "$hqp_cute" != no; then + CUTE_SRCS="Hqp_CUTE_stubs_.C Hqp_CUTE_dummies.C Prg_CUTE.C Prg_CUTE_ST.C Hqp_CUTE.C" + HQP_DEFS="$HQP_DEFS -DHQP_WITH_CUTE=1" +else + CUTE_SRCS="" +fi +AC_SUBST(CUTE_SRCS) + + +# ----------------------------------------------------------------------- +# Configure support for Ascend +# ----------------------------------------------------------------------- + +AC_MSG_CHECKING([--enable_ascend]) +AC_ARG_ENABLE(ascend, + [ --enable-ascend include preliminary Ascend4 interface with HQP], + [hqp_ascend=$enableval], [hqp_ascend=no]) +AC_MSG_RESULT($hqp_ascend) + +if test "$hqp_ascend" != no; then + ASCEND_INCDIR="-I../../ascend4" + ASCEND_SRCS="Hqp_ASCEND_dummies.C Prg_ASCEND.C" + HQP_DEFS="$HQP_DEFS -DHQP_WITH_ASCEND=1" +else + ASCEND_INCDIR="" + ASCEND_SRCS="" +fi +AC_SUBST(ASCEND_INCDIR) +AC_SUBST(ASCEND_SRCS) + +AC_SUBST(HQP_DEFS) +AC_SUBST(IF_DEFS) + +# ----------------------------------------------------------------------- +# Produce outputs +# ----------------------------------------------------------------------- + +AC_OUTPUT(makedefs makedirs odc/Makefile hqp_docp/Makefile) diff --git a/hqp/ChangeLog b/hqp/ChangeLog new file mode 100644 index 0000000..9713e6d --- /dev/null +++ b/hqp/ChangeLog @@ -0,0 +1,15 @@ +4/2/97 +*** HQP 1.2 release +4/6/97 + Hqp_Init.C + - treat SIGXCPU + Prg_CUTE.C, Prg_CUTE_ST.C + - correct writing 'HQP X.Y' for CWRTSN +4/15/97 + Hqp_SqpPowell.c, Hqp_SqpSchittkowski.C + - check for infinite objective values +4/19/97 + Hqp_IpSolver.C + - check for infinite values +4/21/97 +*** HQP 1.3 release \ No newline at end of file diff --git a/hqp/Hqp.C b/hqp/Hqp.C new file mode 100644 index 0000000..826022e --- /dev/null +++ b/hqp/Hqp.C @@ -0,0 +1,83 @@ +/* + * Hqp.C -- implementation of Hqp API + * + * rf, 11/01/00 + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include "Hqp.h" +#include "Hqp_Docp_wrapper.h" + +/* declare things necessary for automatic initialization of Hqp */ +#include +extern "C" int Hqp_Init(Tcl_Interp *); + +//------------------------------------------------------------------------- +extern "C" Hqp_Docp_handle +Hqp_Docp_create(Hqp_Docp_spec &spec, void *clientdata) +{ + // assert that mandatory functions are provided + assert(spec.setup_horizon != NULL); + assert(spec.setup_vars != NULL); + assert(spec.update_vals != NULL); + + // initialize Hqp if this was not done already + if (theInterp == NULL) { + Tcl_Interp *interp = Tcl_CreateInterp(); + assert(Hqp_Init(interp) == TCL_OK); + } + + // create a Hqp_Docp + return new Hqp_Docp_wrapper(spec, clientdata); +} + +//------------------------------------------------------------------------- +extern "C" void +Hqp_Docp_destroy(Hqp_Docp_handle handle) +{ + delete handle; +} + +//------------------------------------------------------------------------- +extern "C" void +Hqp_Docp_alloc_vars(Hqp_Docp_handle handle, + VECP v, VECP vmin, VECP vmax, int n) +{ + handle->alloc_vars(v, vmin, vmax, n); +} + +//------------------------------------------------------------------------- +extern "C" void +Hqp_Docp_update_stage(Hqp_Docp_handle handle, int k, + const VECP x, const VECP u, + VECP f, Real &f0, VECP c, + MATP fx, MATP fu, + VECP f0x, VECP f0u, + MATP cx, MATP cu, + const VECP rf, const VECP rc, + MATP Lxx, MATP Luu, MATP Lxu) +{ + handle->Hqp_Docp::update_stage(k, x, u, f, f0, c, + fx, fu, f0x, f0u, cx, cu, + rf, rc, Lxx, Luu, Lxu); +} + +//========================================================================= diff --git a/hqp/Hqp.h b/hqp/Hqp.h new file mode 100644 index 0000000..407e8ff --- /dev/null +++ b/hqp/Hqp.h @@ -0,0 +1,139 @@ +/* + * Hqp.h -- declarations for HQP (Huge Quadratic Programming) API + * + * rf, 5/28/94 + * + * rf, 2/12/97 + * new result Hqp_Degenerate for singular matrix errors + * no result Hqp_Insolvable anymore as this can't be decited on QP-level + * + * rf, 11/01/00 + * split into Hqp_impl.h (for internal use by implementation) + * and Hqp.h (for external use) + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_H +#define Hqp_H + +/* include type declarations */ +#include + +/** define HQP_API when compiling a Dynamic Link Library (DLL) */ +#ifndef HQP_API +#define HQP_API +#endif + +/** + * Hold pointers to functions provided by an application using HQP. + */ +class Hqp_Docp_spec { +public: + /** Obligatory: setup discrete control horizon. */ + void (*setup_horizon)(void *clientdata, int &k0, int &kf); + + /** Obligatory: setup variables per control interval. */ + void (*setup_vars)(void *clientdata, int k, + VECP x, VECP xmin, VECP xmax, + VECP u, VECP umin, VECP umax, + VECP c, VECP cmin, VECP cmax); + + /** Optional: setup sparse structure and mark linear constraints + per control interval. */ + void (*setup_struct)(void *clientdata, int k, + VECP f0x, VECP f0u, int &f0_lin, + MATP fx, MATP fu, IVECP f_lin, + MATP cx, MATP cu, IVECP c_lin, + MATP Lxx, MATP Luu, MATP Lxu); + + /** Optional: initialize variables via initial-value simulation. */ + void (*init_simulation)(void *clientdata, int k, VECP x, VECP u); + + /** Obligatory: update objective and constraints per control interval. */ + void (*update_vals)(void *clientdata, int k, + const VECP x, const VECP u, + VECP f, Real &f0, VECP c); + + /** Optional: update objective, constraints and derivatives + per control interval. */ + void (*update_stage)(void *clientdata, int k, + const VECP x, const VECP u, + VECP f, Real &f0, VECP c, + MATP fx, MATP fu, + VECP f0x, VECP f0u, + MATP cx, MATP cu, + const VECP rf, const VECP rc, + MATP Lxx, MATP Luu, MATP Lxu); + + /** Constructor initializes all pointers with NULL. */ + Hqp_Docp_spec() { + setup_horizon = NULL; + setup_vars = NULL; + setup_struct = NULL; + init_simulation = NULL; + update_vals = NULL; + update_stage = NULL; + } +}; + +/* forward delcaration of Hqp_Docp implementation */ +class Hqp_Docp; + +/** Handle to address Hqp_Docp implemenation */ +typedef Hqp_Docp *Hqp_Docp_handle; + +extern "C" { + /** Create an instance of Hqp_Docp and return handle. */ + HQP_API Hqp_Docp_handle + Hqp_Docp_create(Hqp_Docp_spec &spec, void *clientdata); + + /** Destroy an instance of Hqp_Docp */ + HQP_API void + Hqp_Docp_destroy(Hqp_Docp_handle handle); + + /** Service routine for allocating vectors. */ + HQP_API void + Hqp_Docp_alloc_vars(Hqp_Docp_handle handle, + VECP v, VECP vmin, VECP vmax, int n); + + /** Default implementation for updating gradients. + * It can be used e.g. to check against own derivatives. */ + HQP_API void + Hqp_Docp_update_stage(Hqp_Docp_handle handle, int k, + const VECP x, const VECP u, + VECP f, Real &f0, VECP c, + MATP fx, MATP fu, + VECP f0x, VECP f0u, + MATP cx, MATP cu, + const VECP rf, const VECP rc, + MATP Lxx, MATP Luu, MATP Lxu); +} + +/** Infinity for non existing constraints and numerical overflow */ +const Real Inf = HUGE_VAL; + +/** check if a number is finite */ +inline bool is_finite(Real x) +{ + return -Inf < x && x < Inf; +} + +#endif diff --git a/hqp/Hqp_ASCEND_dummies.C b/hqp/Hqp_ASCEND_dummies.C new file mode 100644 index 0000000..6b6d551 --- /dev/null +++ b/hqp/Hqp_ASCEND_dummies.C @@ -0,0 +1,56 @@ +/* + * Hqp_ASCEND_dummies.C -- + * dummy functions if ASCEND is not linked + * + * rf, 12/17/99 + */ + +/* + Copyright (C) 1999 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#define ASCEND_DUMMY(name, namestr) \ + extern "C" void name() \ + { \ + fprintf(stderr, \ + "Fatal: ASCEND function %s called but not linked!\n", \ + namestr); \ + exit(-1); \ + } + +ASCEND_DUMMY(slv_register_client, "slv_register_client"); +ASCEND_DUMMY(slv_get_num_solvers_vars, "slv_get_num_solvers_vars"); +ASCEND_DUMMY(slv_get_solvers_var_list, "slv_get_solvers_var_list"); +ASCEND_DUMMY(slv_get_num_solvers_rels, "slv_get_num_solvers_rels"); +ASCEND_DUMMY(slv_get_solvers_rel_list, "slv_get_solvers_rel_list"); +ASCEND_DUMMY(slv_get_obj_relation, "slv_get_obj_relation"); +ASCEND_DUMMY(var_fixed, "var_fixed"); +ASCEND_DUMMY(var_lower_bound, "var_lower_bound"); +ASCEND_DUMMY(var_upper_bound, "var_upper_bound"); +ASCEND_DUMMY(var_value, "var_value"); +ASCEND_DUMMY(var_set_value, "var_set_value"); +ASCEND_DUMMY(var_sindexF, "var_sindexF"); +ASCEND_DUMMY(rel_n_incidencesF, "rel_n_incidencesF"); +ASCEND_DUMMY(rel_incidence_list, "rel_incidence_list"); +ASCEND_DUMMY(rel_equal, "rel_equal"); +ASCEND_DUMMY(rel_less, "rel_less"); +ASCEND_DUMMY(relman_eval, "relman_eval"); +ASCEND_DUMMY(relman_diff_grad, "relman_diff_grad"); diff --git a/hqp/Hqp_CUTE.C b/hqp/Hqp_CUTE.C new file mode 100644 index 0000000..88684eb --- /dev/null +++ b/hqp/Hqp_CUTE.C @@ -0,0 +1,75 @@ +/* + * Tcl_AppInit and main function for CUTE + * + * rf, 4/10/97 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +/* + * initialization of a Tcl application that runs HQP + */ + +extern "C" int Hqp_Init (Tcl_Interp *interp); +extern "C" int Tcl_AppInit(Tcl_Interp *interp) +{ + if (Tcl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + + if (Hqp_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + * a Tcl main function to be called from FORTRAN + */ + +extern "C" void tclmn_(char *arg1) +{ + char cmdline[256]; + char *argv[2]; + int idx; + + strcpy(cmdline, "hqpmin"); + cmdline[6] = ' '; + idx = 0; + while (arg1[idx] != ' ' && idx < 248) { + cmdline[7 + idx] = arg1[idx]; + idx++; + } + cmdline[7 + idx] = '\0'; + + argv[0] = cmdline; + argv[1] = cmdline + 7; + + Tcl_Main(2, argv, Tcl_AppInit); +} + +extern "C" void tclmn(char *arg1) +{ + tclmn_(arg1); +} diff --git a/hqp/Hqp_CUTE_dummies.C b/hqp/Hqp_CUTE_dummies.C new file mode 100644 index 0000000..8cf9af0 --- /dev/null +++ b/hqp/Hqp_CUTE_dummies.C @@ -0,0 +1,118 @@ +/* + * Hqp_CUTE_dummies.C -- + * dummy procedures used if CUTE is not linked + * + * rf, 3/19/97 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#ifndef fint +#define fint int +#endif + +#ifndef freal +#define freal double +#endif + +#ifndef fbool +#define fbool int +#endif + +extern "C" void +csize(fint *N, fint *M, fint *NNZJ, fint *NNZH) +{ + fprintf(stderr, "Fatal: CUTE procedure CSIZE called but not linked!\n"); + exit(-1); +} + +extern "C" void +cinit(fint *N, fint *M, freal *X0, freal *BL, freal *BU, freal *INF, + fbool *EQUATN, fbool *LINEAR, freal *V0, freal *CL, freal *CU, + fbool *EFIRST, fbool *LFIRST, fbool *NVFRST) +{ + fprintf(stderr, "Fatal: CUTE procedure CINIT called but not linked!\n"); + exit(-1); +} + +extern "C" void +cfn(const fint *N, const fint *M, const freal *X, + freal *F, const fint *LC, freal *C) +{ + fprintf(stderr, "Fatal: CUTE procedure CFN called but not linked!\n"); + exit(-1); +} + +extern "C" void +csgr(const fint *N, const fint *M, const fbool *GRLAGF, + const fint *LV, const freal *V, const freal *X, + fint *NNZSCJ, const fint *LSCJAC, freal *SCJAC, + fint *INDVAR, fint *INDFUN) +{ + fprintf(stderr, "Fatal: CUTE procedure CSGR called but not linked!\n"); + exit(-1); +} + +extern "C" void +cscifg(const fint *N, const fint *I, const freal *X, + freal *CI, fint *NNZSGC, const fint *LSGCI, freal *SGCI, + fint *IVSGCI, fbool *GRAD) +{ + fprintf(stderr, "Fatal: CUTE procedure CSCIFG called but not linked!\n"); + exit(-1); +} + +extern "C" void +csgrsh(const fint *N, const fint *M, const freal *X, const fbool *GRLAGF, + const fint *LV, const freal *V, + fint *NNZSCJ, const fint *LSCJAC, freal *SCJAC, + fint *INDVAR, fint *INDFUN, + fint *NNZSH, const fint *LSH, freal *SH, + fint *IRNSH, fint *ICNSH) +{ + fprintf(stderr, "Fatal: CUTE procedure CSGRSH called but not linked!\n"); + exit(-1); +} + +extern "C" void +csgreh(const fint *N, const fint *M, const freal *X, const fbool *GRLAGF, + const fint *LV, const freal *V, + fint *NNZSCJ, const fint *LSCJAC, freal *SCJAC, + fint *INDVAR, fint *INDFUN, fint *NE, fint *IRNHI, + const fint *LIRNHI, const fint *LE, fint *IPRNHI, + freal *HI, const fint *LHI, fint *IPRHI, const fbool *BYROWS) +{ + fprintf(stderr, "Fatal: CUTE procedure CSGREH called but not linked!\n"); + exit(-1); +} + +extern "C" void +cwrtsn(const fint *N, const fint *M, const char *header, + const freal *F, const freal *X, const freal *V) +{ + fprintf(stderr, "Fatal: CUTE procedure CWRTSN called but not linked!\n"); + exit(-1); +} + + +//========================================================================= diff --git a/hqp/Hqp_CUTE_stubs_.C b/hqp/Hqp_CUTE_stubs_.C new file mode 100644 index 0000000..8ea6ec6 --- /dev/null +++ b/hqp/Hqp_CUTE_stubs_.C @@ -0,0 +1,178 @@ +/* + * Hqp_CUTE_stubs_.C -- + * stub procedures for CUTE, + * needed as some Fortran compilers add underscore to symbol names + * + * rf, 3/19/97 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#ifndef fint +#define fint int +#endif + +#ifndef freal +#define freal double +#endif + +#ifndef fbool +#define fbool int +#endif + +extern "C" void +csize(fint *N, fint *M, fint *NNZJ, fint *NNZH); + +extern "C" void +csize_(fint *N, fint *M, fint *NNZJ, fint *NNZH) +{ + csize(N, M, NNZJ, NNZH); +} + +extern "C" void +cinit(fint *N, fint *M, freal *X0, freal *BL, freal *BU, freal *INF, + fbool *EQUATN, fbool *LINEAR, freal *V0, freal *CL, freal *CU, + fbool *EFIRST, fbool *LFIRST, fbool *NVFRST); + +extern "C" void +cinit_(fint *N, fint *M, freal *X0, freal *BL, freal *BU, freal *INF, + fbool *EQUATN, fbool *LINEAR, freal *V0, freal *CL, freal *CU, + fbool *EFIRST, fbool *LFIRST, fbool *NVFRST) +{ + cinit(N, M, X0, BL, BU, INF, + EQUATN, LINEAR, V0, CL, CU, + EFIRST, LFIRST, NVFRST); +} + +extern "C" void +cfn(const fint *N, const fint *M, const freal *X, + freal *F, const fint *LC, freal *C); + +extern "C" void +cfn_(const fint *N, const fint *M, const freal *X, + freal *F, const fint *LC, freal *C) +{ + cfn(N, M, X, + F, LC, C); +} + +extern "C" void +csgr(const fint *N, const fint *M, const fbool *GRLAGF, + const fint *LV, const freal *V, const freal *X, + fint *NNZSCJ, const fint *LSCJAC, freal *SCJAC, + fint *INDVAR, fint *INDFUN); + +extern "C" void +csgr_(const fint *N, const fint *M, const fbool *GRLAGF, + const fint *LV, const freal *V, const freal *X, + fint *NNZSCJ, const fint *LSCJAC, freal *SCJAC, + fint *INDVAR, fint *INDFUN) +{ + csgr(N, M, GRLAGF, + LV, V, X, + NNZSCJ, LSCJAC, SCJAC, + INDVAR, INDFUN); +} + +extern "C" void +cscifg(const fint *N, const fint *I, const freal *X, + freal *CI, fint *NNZSGC, const fint *LSGCI, freal *SGCI, + fint *IVSGCI, fbool *GRAD); + +extern "C" void +cscifg(const fint *N, const fint *I, const freal *X, + freal *CI, fint *NNZSGC, const fint *LSGCI, freal *SGCI, + fint *IVSGCI, fbool *GRAD); + +extern "C" void +cscifg_(const fint *N, const fint *I, const freal *X, + freal *CI, fint *NNZSGC, const fint *LSGCI, freal *SGCI, + fint *IVSGCI, fbool *GRAD) +{ + cscifg(N, I, X, + CI, NNZSGC, LSGCI, SGCI, + IVSGCI, GRAD); +} + +extern "C" void +csgrsh(const fint *N, const fint *M, const freal *X, const fbool *GRLAGF, + const fint *LV, const freal *V, + fint *NNZSCJ, const fint *LSCJAC, freal *SCJAC, + fint *INDVAR, fint *INDFUN, + fint *NNZSH, const fint *LSH, freal *SH, + fint *IRNSH, fint *ICNSH); + +extern "C" void +csgrsh_(const fint *N, const fint *M, const freal *X, const fbool *GRLAGF, + const fint *LV, const freal *V, + fint *NNZSCJ, const fint *LSCJAC, freal *SCJAC, + fint *INDVAR, fint *INDFUN, + fint *NNZSH, const fint *LSH, freal *SH, + fint *IRNSH, fint *ICNSH) +{ + csgrsh(N, M, X, GRLAGF, + LV, V, + NNZSCJ, LSCJAC, SCJAC, + INDVAR, INDFUN, + NNZSH, LSH, SH, + IRNSH, ICNSH); +} + +extern "C" void +csgreh(const fint *N, const fint *M, const freal *X, const fbool *GRLAGF, + const fint *LV, const freal *V, + fint *NNZSCJ, const fint *LSCJAC, freal *SCJAC, + fint *INDVAR, fint *INDFUN, fint *NE, fint *IRNHI, + const fint *LIRNHI, const fint *LE, fint *IPRNHI, + freal *HI, const fint *LHI, fint *IPRHI, const fbool *BYROWS); + +extern "C" void +csgreh_(const fint *N, const fint *M, const freal *X, const fbool *GRLAGF, + const fint *LV, const freal *V, + fint *NNZSCJ, const fint *LSCJAC, freal *SCJAC, + fint *INDVAR, fint *INDFUN, fint *NE, fint *IRNHI, + const fint *LIRNHI, const fint *LE, fint *IPRNHI, + freal *HI, const fint *LHI, fint *IPRHI, const fbool *BYROWS) +{ + csgreh(N, M, X, GRLAGF, + LV, V, + NNZSCJ, LSCJAC, SCJAC, + INDVAR, INDFUN, NE, IRNHI, + LIRNHI, LE, IPRNHI, + HI, LHI, IPRHI, BYROWS); +} + +extern "C" void +cwrtsn(const fint *N, const fint *M, const char *header, + const freal *F, const freal *X, const freal *V); + +extern "C" void +cwrtsn_(const fint *N, const fint *M, const char *header, + const freal *F, const freal *X, const freal *V) +{ + cwrtsn(N, M, header, + F, X, V); +} + + +//========================================================================= diff --git a/hqp/Hqp_Client.C b/hqp/Hqp_Client.C new file mode 100644 index 0000000..9736bcc --- /dev/null +++ b/hqp/Hqp_Client.C @@ -0,0 +1,70 @@ +/* + * Hqp_Client.C -- class definition + * + * rf, 8/12/94 + * + * rf, 8/13/98 + * - make Hqp_Client an exchangeable interface class + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#include "Hqp_Client.h" +#include "Hqp_Program.h" + +IF_CLASS_DEFINE("Client", Hqp_Client, Hqp_Solver); + +//-------------------------------------------------------------------------- +int Hqp_Client::step(int, char *[], char **result) +{ + *result = "Hqp_Client::step not implemented"; + return IF_ERROR; +} + +//-------------------------------------------------------------------------- +int Hqp_Client::solve(IF_CMD_ARGS) +{ + FILE *fp1, *fp2; + + if ((fp1 = fopen("/tmp/comm/pipe1", "w")) == NULL) + perror("opening pipe1"); + sp_foutput(fp1, _qp->Q); + v_foutput(fp1, _qp->c); + sp_foutput(fp1, _qp->A); + v_foutput(fp1, _qp->b); + sp_foutput(fp1, _qp->C); + v_foutput(fp1, _qp->d); + fclose(fp1); + + if ((fp2 = fopen("/tmp/comm/pipe2", "r")) == NULL) + perror("opening pipe2"); + _qp->x = v_finput(fp2, _qp->x); + _y = v_finput(fp2, _y); + _z = v_finput(fp2, _z); + fclose(fp2); + + _result = Hqp_Optimal; + + return IF_OK; +} + diff --git a/hqp/Hqp_Client.h b/hqp/Hqp_Client.h new file mode 100644 index 0000000..3379d3b --- /dev/null +++ b/hqp/Hqp_Client.h @@ -0,0 +1,58 @@ +/* + * Hqp_Client.h -- + * - quadratic solver for communicating with a "compute server" + * + * rf, 8/12/94 + * + * rf, 8/13/98 + * - make Hqp_Client an exchangeable interface class + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_Client_H +#define Hqp_Client_H + +#include "Hqp_Solver.h" + +class Hqp_Client: public Hqp_Solver { + + public: + + Hqp_Client() {} + ~Hqp_Client() {} + + // initializing a program (updating for SQP integration) + // is empty as only complete tasks are processed that time + int init(IF_CMD_ARGS) {return IF_OK;} + int update(IF_CMD_ARGS) {return IF_OK;} + + // solving a program (hot start for SQP integration) + int cold_start(IF_CMD_ARGS) {return IF_OK;} + int hot_start(IF_CMD_ARGS) {return IF_OK;} + int step(IF_DEF_ARGS); + int solve(IF_DEF_ARGS); + + char *name() {return "Client";} +}; + +#endif + + diff --git a/hqp/Hqp_Docp.C b/hqp/Hqp_Docp.C new file mode 100644 index 0000000..9d72112 --- /dev/null +++ b/hqp/Hqp_Docp.C @@ -0,0 +1,1096 @@ +/* + * Hqp_Docp.C -- class definition + * + * rf, 11/12/94 + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#include "Hqp_Docp.h" +#include "Hqp_Program.h" + +#include +#include +#include + +typedef If_Method If_Cmd; + +// store association of constraints with _qp +//------------------------------------------ +class Hqp_DocpAssoc { + + public: + + int granul; // quantity for growing up vectors + int offs; // offset into _qp vectors and matrices + int dim; // dimension of vectors vals, idxs, and flags + VECP vals; // values of bounds + IVECP idxs; // index set to associate constraints with variables + IVECP start; // start index for each k into vals, and idxs + + Hqp_DocpAssoc(); + ~Hqp_DocpAssoc(); + + void reset(); + void new_k(); + void add_cns(Real val, int idx); + + void sp_insert_mat(int k, SPMAT *J, int joffs, + const MATP mat, int mat_offs); + void sp_extract_mat(int k, const SPMAT *J, int joffs, + MATP mat, int mat_offs, const IVECP lin); + void sp_update_mat(int k, SPMAT *J, int joffs, + const MATP mat, int mat_offs, const IVECP lin); + + void sv_mltadd_vec(int k, Real s, const VECP z, + VECP vec, int vec_offs); +}; + +//------------------------------------------------------------------------- +Hqp_DocpAssoc::Hqp_DocpAssoc() +{ + granul = 100; + vals = v_get(granul); + idxs = iv_get(granul); + start = iv_get(granul); + reset(); +} + +//------------------------------------------------------------------------- +Hqp_DocpAssoc::~Hqp_DocpAssoc() +{ + v_free(vals); + iv_free(idxs); + iv_free(start); +} + +//------------------------------------------------------------------------- +void Hqp_DocpAssoc::reset() +{ + offs = 0; + dim = 0; + v_resize(vals, 0); + iv_resize(idxs, 0); + iv_resize(start, 1); + start[0] = 0; +} + +//------------------------------------------------------------------------- +void Hqp_DocpAssoc::new_k() +{ + // store current dim as start index for new k + + iv_expand(start, 1, granul); + start[(int)start->dim - 1] = dim; +} + +//------------------------------------------------------------------------- +void Hqp_DocpAssoc::add_cns(Real val, int idx) +{ + v_expand(vals, 1, granul); + iv_expand(idxs, 1, granul); + vals[dim] = val; + idxs[dim] = idx; + dim ++; +} + +//------------------------------------------------------------------------- +void Hqp_DocpAssoc::sp_insert_mat(int k, SPMAT *J, int joffs, + const MATP mat, int mat_offs) +{ + int i, iend; + int mat_idx; + + iend = start[k+1]; + for (i = start[k]; i < iend; i++) { + mat_idx = idxs[i] - mat_offs; + sp_insert_mrow(J, offs + i - mat_idx, joffs, mat, mat_idx); + } +} + +//------------------------------------------------------------------------- +void Hqp_DocpAssoc::sp_extract_mat(int k, const SPMAT *J, int joffs, + MATP mat, int mat_offs, const IVECP lin) +{ + int i, iend; + int mat_idx; + + iend = start[k+1]; + for (i = start[k]; i < iend; i++) { + if (!lin[idxs[i]]) { + mat_idx = idxs[i] - mat_offs; + sp_extract_mrow(J, offs + i - mat_idx, joffs, mat, mat_idx); + } + } +} + +//------------------------------------------------------------------------- +void Hqp_DocpAssoc::sp_update_mat(int k, SPMAT *J, int joffs, + const MATP mat, int mat_offs, + const IVECP lin) +{ + int i, iend; + int mat_idx; + + iend = start[k+1]; + for (i = start[k]; i < iend; i++) { + if (!lin[idxs[i]]) { + mat_idx = idxs[i] - mat_offs; + sp_update_mrow(J, offs + i - mat_idx, joffs, mat, mat_idx); + } + } +} + +//------------------------------------------------------------------------- +void Hqp_DocpAssoc::sv_mltadd_vec(int k, Real s, const VECP z, + VECP vec, int vec_offs) +{ + int i, iend; + int ioffs = offs + start[k]; + Real *z_ve = z->ve; + Real *v_ve = vec->ve; + + iend = start[k+1]; + for (i = start[k]; i < iend; i++, ioffs++) { + v_ve[idxs[i]-vec_offs] += s * z_ve[ioffs]; + } +} + +//========================================================================= + +const int Hqp_Docp::Periodical = 1; + +//------------------------------------------------------------------------- +Hqp_Docp::Hqp_Docp() +{ + _xk = &_xk_head; + _uk = &_uk_head; + _fk = &_fk_head; + _s1 = &_s1_head; + _s2 = &_s2_head; + _k0 = 0; + _kf = 50; + _nxs = iv_get(1); + _nus = iv_get(1); + _xus_init = v_get(1); + _granul = 100; + _f0_lin = iv_get(1); + _xu_eq = new Hqp_DocpAssoc; + _xu_lb = new Hqp_DocpAssoc; + _xu_ub = new Hqp_DocpAssoc; + _f_lin = iv_get(1); + _f_start = iv_get(1); + _cns_eq = new Hqp_DocpAssoc; + _cns_lb = new Hqp_DocpAssoc; + _cns_ub = new Hqp_DocpAssoc; + _cns_lin = iv_get(1); + _cns_start = iv_get(1); + _x_type = iv_get(1); + _fbd_evals = 0; + + _ifList.append(new If_Cmd("prg_simulate", + &Hqp_Docp::simulate, this)); + _ifList.append(new If_IntVec("prg_nxs", &_nxs, "r")); + _ifList.append(new If_IntVec("prg_nus", &_nus, "r")); + _ifList.append(new If_Int("prg_fbd_evals", &_fbd_evals)); +} + +//------------------------------------------------------------------------- +Hqp_Docp::~Hqp_Docp() +{ + iv_free(_x_type); + delete _xu_eq; + delete _xu_lb; + delete _xu_ub; + iv_free(_nus); + iv_free(_nxs); + v_free(_xus_init); + iv_free(_f_start); + iv_free(_f_lin); + delete _cns_eq; + delete _cns_lb; + delete _cns_ub; + iv_free(_cns_lin); + iv_free(_cns_start); + iv_free(_f0_lin); +} + +//------------------------------------------------------------------------- +void Hqp_Docp::horizon(int k0, int kf) +{ + _k0 = k0; + _kf = kf; +} + +//------------------------------------------------------------------------- +void Hqp_Docp::alloc_vars(VECP v, VECP vmin, VECP vmax, int n) +{ + v_resize(v, n); + v_resize(vmin, n); + v_resize(vmax, n); + v_set(v, 0.0); + v_set(vmin, -Inf); + v_set(vmax, Inf); +} + +//------------------------------------------------------------------------- +void Hqp_Docp::setup_horizon(int &, int &) +{ + // empty default implementation, i.e. + // -- use preset _k0 and _kf +} + +//------------------------------------------------------------------------- +void Hqp_Docp::setup_struct(int, VECP, VECP, int &, + MATP, MATP, IVECP, + MATP, MATP, IVECP, + MATP, MATP, MATP) +{ + // empty default implementation means: + // -- matrices are full + // -- objective and all constraints are nonlinear +} + +//------------------------------------------------------------------------- +void Hqp_Docp::init_simulation(int k, VECP x, VECP u) +{ + // empty default implementation, i.e. + // the control parameters and initial states of the current + // iterate _x are used +} + +//------------------------------------------------------------------------- +// parse_constr: +// -- split constraints up into: +// equality constraints, lower bounds, upper bounds +// +void Hqp_Docp::parse_constr(const VECP cmin, const VECP cmax, + int idx, Hqp_DocpAssoc *eq, + Hqp_DocpAssoc *lb, Hqp_DocpAssoc *ub) +{ + assert(cmin->dim == cmax->dim); + + int i, iend = cmin->dim; + + for (i = 0; i < iend; i++) { + if (cmin[i] == cmax[i]) { + assert(is_finite(cmin[i])); + eq->add_cns(cmin[i], idx); + } + else { + if (cmin[i] > -Inf) + lb->add_cns(cmin[i], idx); + if (cmax[i] < Inf) + ub->add_cns(cmax[i], idx); + } + idx ++; + } + + eq->new_k(); + lb->new_k(); + ub->new_k(); +} + +//------------------------------------------------------------------------- +void Hqp_Docp::setup() +{ + // setup optimization horizon + setup_horizon(_k0, _kf); + + // setup and initialize variables + setup_x(); + init_x(); + + // setup the sparsity structure + setup_qp(); +} + +//------------------------------------------------------------------------- +void Hqp_Docp::setup_x() +{ + int i, k, K; + int nsp, nfsp; + int ncnssp; + VECP x, xmin, xmax; + VECP u, umin, umax; + VECP c, cmin, cmax; + + K = _kf - _k0; + + _xu_eq->reset(); + _xu_lb->reset(); + _xu_ub->reset(); + + _cns_eq->reset(); + _cns_lb->reset(); + _cns_ub->reset(); + + // + // initialize variables and constraints + // + + v_resize(_xus_init, 0); + nsp = 0; + nfsp = 0; + iv_resize(_f_start, K+2); // two additional + iv_resize(_nxs, K+1); + iv_resize(_nus, K+1); + + ncnssp = 0; + iv_resize(_cns_start, K+2); // one additional for the final values + + x = v_get(1); + xmin = v_get(1); + xmax = v_get(1); + u = v_get(1); + umin = v_get(1); + umax = v_get(1); + c = v_get(1); + cmin = v_get(1); + cmax = v_get(1); + + for (k = 0; k <= K; k++) { + v_resize(x, 0); + v_resize(xmin, 0); + v_resize(xmax, 0); + v_resize(u, 0); + v_resize(umin, 0); + v_resize(umax, 0); + v_resize(c, 0); + v_resize(cmin, 0); + v_resize(cmax, 0); + + setup_vars(_k0+k, x, xmin, xmax, u, umin, umax, c, cmin, cmax); + assert(xmin->dim == x->dim && x->dim == xmax->dim); + assert(umin->dim == u->dim && u->dim == umax->dim); + assert(cmin->dim == c->dim && c->dim == cmax->dim); + + if (k == 0) { + // + // treat special state constraints here + // -- assume equal initial/final state for xmin[i] = xmax[i] (= Inf) + // + iv_resize(_x_type, xmin->dim); + iv_zero(_x_type); + for (i = 0; i < (int)xmin->dim; i++) { + if (xmin[i] == xmax[i] && xmin[i] == Inf) { + _x_type[i] = Periodical; + xmin[i] = -Inf; + } + } + } + + // grow size of vector for initial values + v_expand(_xus_init, x->dim + u->dim, _granul); + + // parse state variables and bounds + for (i = 0; i < (int)x->dim; i++) + _xus_init[nsp + i] = x[i]; + parse_constr(xmin, xmax, nsp, _xu_eq, _xu_lb, _xu_ub); + nsp += xmin->dim; + _nxs[k] = xmin->dim; + if (k > 0) { + _f_start[k-1] = nfsp; + nfsp += xmin->dim; + } + + // parse control parameters and bounds + for (i = 0; i < (int)u->dim; i++) + _xus_init[nsp + i] = u[i]; + parse_constr(umin, umax, nsp, _xu_eq, _xu_lb, _xu_ub); + nsp += umin->dim; + _nus[k] = umin->dim; + + // parse constraints + _cns_start[k] = ncnssp; + parse_constr(cmin, cmax, ncnssp, _cns_eq, _cns_lb, _cns_ub); + ncnssp += cmin->dim; + } + + // final state + + assert(_nus[K] == 0); + _f_start[K] = nfsp; + _f_start[K+1] = nfsp; + _cns_start[K+1] = ncnssp; + + v_free(x); + v_free(xmin); + v_free(xmax); + v_free(u); + v_free(umin); + v_free(umax); + v_free(c); + v_free(cmin); + v_free(cmax); + + // adapt dimensions + + if (nfsp != (int)_f_lin->dim) + iv_resize(_f_lin, nfsp); + + if (ncnssp != (int)_cns_lin->dim) + iv_resize(_cns_lin, ncnssp); + + if (nsp != (int)_x->dim) + v_resize(_x, nsp); + + if (K+1 != (int)_f0_lin->dim) + iv_resize(_f0_lin, K+1); + + // initialize constraint offsets for large QP + + int mesp = nfsp; + _xu_eq->offs = mesp; mesp += _xu_eq->dim; + _cns_eq->offs = mesp; + + int misp = 0; + _xu_lb->offs = misp; misp += _xu_lb->dim; + _xu_ub->offs = misp; misp += _xu_ub->dim; + _cns_lb->offs = misp; misp += _cns_lb->dim; + _cns_ub->offs = misp; +} + +//------------------------------------------------------------------------- +void Hqp_Docp::setup_qp() +{ + int nsp; // variables + int mesp; // equality constraints + int misp; // inequality constraints + int i, iend, offs; + int k; + MATP fx, fu, cx, cu; + MATP Lxx, Luu, Lxu; + IVEC f_lin, c_lin; + int K = _kf - _k0; + int nx, nu, nf, nc; + int kf, kxu; + + // + // assign constraints to _qp: + // _qp->A, _qp->b: + // + system equations + // + _xu_eq + // + _cns_eq + // _qp->C, _qp->d: + // + _xu_lb + // + _xu_ub + // + _cns_lb + // + _cns_ub + // + + nsp = _x->dim; + + mesp = _f_lin->dim + _xu_eq->dim + _cns_eq->dim; + + // count initial and final state constraints + iend = min(_nxs[0], _nxs[K]); + for (i = 0; i < iend; i++) { + if (_x_type[i] & Periodical) + mesp++; + } + + misp = _xu_lb->dim + _xu_ub->dim + _cns_lb->dim + _cns_ub->dim; + + // + // allocate _qp + // + + _qp->resize(nsp, mesp, misp, 10, 10, 2); + + // + // init sparsity structure and set constant values + // + + // initial and final state constraints + + offs = _f_lin->dim + _xu_eq->dim + _cns_eq->dim; + for (i = 0; i < iend; i++) { + if (_x_type[i] & Periodical) { + sp_set_val(_qp->A, offs, i, 1.0); + sp_set_val(_qp->A, offs, _x->dim - _nxs[K] + i, -1.0); + offs++; + } + } + + // equality constraints for state/control variables (e.g. initial state) + + offs = _xu_eq->offs; + iend = _xu_eq->dim; + for (i = 0; i < iend; i++) + sp_set_val(_qp->A, offs + i, _xu_eq->idxs[i], 1.0); + + // inequality constraints for state/control variables + + offs = _xu_lb->offs; + iend = _xu_lb->dim; + for (i = 0; i < iend; i++) + sp_set_val(_qp->C, offs + i, _xu_lb->idxs[i], 1.0); + + offs = _xu_ub->offs; + iend = _xu_ub->dim; + for (i = 0; i < iend; i++) + sp_set_val(_qp->C, offs + i, _xu_ub->idxs[i], -1.0); + + // discrete--time structure + + fx = m_get(1, 1); + fu = m_get(1, 1); + cx = m_get(1, 1); + cu = m_get(1, 1); + Lxx = m_get(1, 1); + Luu = m_get(1, 1); + Lxu = m_get(1, 1); + + kf = 0; + kxu = 0; + for (k = 0; k <= K; k++) { + nx = _nxs[k]; + nu = _nus[k]; + nf = _f_start[k+1] - _f_start[k]; + nc = _cns_start[k+1] - _cns_start[k]; + m_resize(fx, nf, nx); + m_resize(fu, nf, nu); + iv_part(_f_lin, _f_start[k], nf, &f_lin); + m_resize(cx, nc, nx); + m_resize(cu, nc, nu); + iv_part(_cns_lin, _cns_start[k], nc, &c_lin); + m_resize(Lxx, nx, nx); + m_resize(Luu, nu, nu); + m_resize(Lxu, nx, nu); + + v_part(_qp->c, kxu, nx, _s1); // f0x + v_part(_qp->c, kxu+nx, nu, _s2); // f0u + v_ones(_s1); + v_ones(_s2); + _f0_lin[k] = 0; + + m_ones(fx); + m_ones(fu); + iv_set(&f_lin, 0); + + m_ones(cx); + m_ones(cu); + iv_set(&c_lin, 0); + + m_ones(Lxx); + m_ones(Luu); + m_ones(Lxu); + + setup_struct(_k0+k, _s1, _s2, _f0_lin[k], + fx, fu, &f_lin, cx, cu, &c_lin, + Lxx, Luu, Lxu); + + sp_insert_mat(_qp->A, kf, kxu, fx); + sp_insert_mat(_qp->A, kf, kxu+nx, fu); + for (i = 0; i < nf; i++) + sp_set_val(_qp->A, kf + i, kxu+nx+nu + i, -1.0); + + symsp_insert_symmat(_qp->Q, kxu, Lxx); + symsp_insert_symmat(_qp->Q, kxu+nx, Luu); + sp_insert_mat(_qp->Q, kxu, kxu+nx, Lxu); + + _cns_eq->sp_insert_mat(k, _qp->A, kxu, cx, _cns_start[k]); + _cns_eq->sp_insert_mat(k, _qp->A, kxu+nx, cu, _cns_start[k]); + + _cns_lb->sp_insert_mat(k, _qp->C, kxu, cx, _cns_start[k]); + _cns_lb->sp_insert_mat(k, _qp->C, kxu+nx, cu, _cns_start[k]); + + sm_mlt(-1.0, cx, cx); + sm_mlt(-1.0, cu, cu); + _cns_ub->sp_insert_mat(k, _qp->C, kxu, cx, _cns_start[k]); + _cns_ub->sp_insert_mat(k, _qp->C, kxu+nx, cu, _cns_start[k]); + + kf += nf; + kxu += nx+nu; + } + + // no initial guess + sp_zero(_qp->Q); + + m_free(fx); + m_free(fu); + m_free(cx); + m_free(cu); + m_free(Lxx); + m_free(Luu); + m_free(Lxu); +} + +// for now just repeat setup of variables and update bounds +//------------------------------------------------------------------------- +void Hqp_Docp::reinit_bd() +{ + // store back current dimensions for check at end of this method + int x_dim = _x->dim; + int xu_eq_dim = _xu_eq->dim; + int xu_lb_dim = _xu_lb->dim; + int xu_ub_dim = _xu_ub->dim; + int cns_eq_dim = _cns_eq->dim; + int cns_lb_dim = _cns_lb->dim; + int cns_ub_dim = _cns_ub->dim; + + setup_x(); + + // check that dimenstions did not change + if (x_dim != _x->dim + || xu_eq_dim != _xu_eq->dim + || xu_lb_dim != _xu_lb->dim + || xu_ub_dim != _xu_ub->dim + || cns_eq_dim != _cns_eq->dim + || cns_lb_dim != _cns_lb->dim + || cns_ub_dim != _cns_ub->dim) { + error(E_SIZES, "Hqp_Docp::reinit_bd"); + } + + update_bounds(); +} + +//------------------------------------------------------------------------- +void Hqp_Docp::init_x() +{ + v_copy(_xus_init, _x); +} + +//------------------------------------------------------------------------- +int Hqp_Docp::simulate(IF_CMD_ARGS) +{ + int k, kxu; + int nx, nu, nf, nc; + Real f0k; + VECP c; + int K = _kf - _k0; + + // + // for k = 0, ... , K + // -- call init_solution() for xk and uk + // -- simulate for x{k+1} + // -- sum up all f0k's already here + // + + c = v_get(1); + kxu = 0; + _f = 0.0; + for (k = 0; k <= K; k++) { + nx = _nxs[k]; + nu = _nus[k]; + nf = _f_start[k+1] - _f_start[k]; + nc = _cns_start[k+1] - _cns_start[k]; + v_part(_x, kxu, nx, _xk); + v_part(_x, kxu+nx, nu, _uk); + v_part(_x, kxu+nx+nu, nf, _fk); + init_simulation(_k0+k, _xk, _uk); + c = v_resize(c, nc); + update_vals(_k0+k, _xk, _uk, _fk, f0k, c); + _f += f0k; + kxu += nx+nu; + } + + v_free(c); + + return IF_OK; +} + +//------------------------------------------------------------------------- +void Hqp_Docp::update_fbd() +{ + int i, k, kxu, kf; + int nx, nu, nf, nc; + int offs, iend; + Real f0k; + Real *v_ve; + VECP c; + int K = _kf - _k0; + + // update user--calculated values + + c = v_get(1); + kf = 0; + kxu = 0; + _f = 0.0; + for (k = 0; k <= K; k++) { + nx = _nxs[k]; + nu = _nus[k]; + nf = _f_start[k+1] - _f_start[k]; + nc = _cns_start[k+1] - _cns_start[k]; + v_part(_x, kxu, nx, _xk); + v_part(_x, kxu+nx, nu, _uk); + v_part(_qp->b, kf, nf, _fk); + v_resize(c, nc); + v_zero(_fk); + f0k = 0.0; + + update_vals(_k0+k, _xk, _uk, _fk, f0k, c); + + v_sub(_fk, v_part(_x, kxu+nx+nu, nf, _xk), _fk); + + _f += f0k; + + // break if _f is not finite + if (!is_finite(_f)) + break; + + offs = _cns_start[k]; + v_ve = _qp->b->ve + _cns_eq->offs; + iend = _cns_eq->start[k+1]; + for (i = _cns_eq->start[k]; i < iend; i++) + v_ve[i] = c[_cns_eq->idxs[i]-offs] - _cns_eq->vals[i]; + + v_ve = _qp->d->ve + _cns_lb->offs; + iend = _cns_lb->start[k+1]; + for (i = _cns_lb->start[k]; i < iend; i++) + v_ve[i] = c[_cns_lb->idxs[i]-offs] - _cns_lb->vals[i]; + + v_ve = _qp->d->ve + _cns_ub->offs; + iend = _cns_ub->start[k+1]; + for (i = _cns_ub->start[k]; i < iend; i++) + v_ve[i] = _cns_ub->vals[i] - c[_cns_ub->idxs[i]-offs]; + + kf += nf; + kxu += nx+nu; + } + + v_free(c); + + // update state/control bounds and initial/final states + update_bounds(); + + _fbd_evals++; +} + +//------------------------------------------------------------------------- +void Hqp_Docp::update_bounds() +{ + int i, iend, offs; + int K = _kf - _k0; + Real *x_ve, *v_ve; + int *idxs_ive; + VEC v_head; + VECP v = &v_head; + + x_ve = _x->ve; + + v_part(_qp->b, _xu_eq->offs, _xu_eq->dim, v); + v_ve = v->ve; + idxs_ive = _xu_eq->idxs->ive; + iend = _xu_eq->dim; + for (i = 0; i < iend; i++) + v_ve[i] = x_ve[idxs_ive[i]]; + v_sub(v, _xu_eq->vals, v); + + v_part(_qp->d, _xu_lb->offs, _xu_lb->dim, v); + v_ve = v->ve; + idxs_ive = _xu_lb->idxs->ive; + iend = _xu_lb->dim; + for (i = 0; i < iend; i++) + v_ve[i] = x_ve[idxs_ive[i]]; + v_sub(v, _xu_lb->vals, v); + + v_part(_qp->d, _xu_ub->offs, _xu_ub->dim, v); + v_ve = v->ve; + idxs_ive = _xu_ub->idxs->ive; + iend = _xu_ub->dim; + for (i = 0; i < iend; i++) + v_ve[i] = -x_ve[idxs_ive[i]]; + v_add(v, _xu_ub->vals, v); + + // update initial/final state constraints + + iend = min(_nxs[0], _nxs[K]); + v_part(_x, 0, _nxs[0], _xk); + v_part(_x, _x->dim - _nxs[K], _nxs[K], _fk); + offs = _f_lin->dim + _xu_eq->dim + _cns_eq->dim; + for (i = 0; i < iend; i++) { + if (_x_type[i] & Periodical) { + _qp->b->ve[offs] = _xk[i] - _fk[i]; + offs++; + } + } +} + +//------------------------------------------------------------------------- +void Hqp_Docp::update(const VECP y, const VECP z) +{ + int i, iend, k; + int K = _kf - _k0; + int nx, nu, nf, nc; + int kf, kxu; + MATP fx, fu, cx, cu; + SPMAT *A = _qp->A; + MATP Lxx, Luu, Lxu; + VECP c, vc, vf; + Real f0k; + Real *v_ve; + int offs; + + if ((const VEC *)y == NULL || (const VEC *)z == NULL) + error(E_NULL, "Hqp_Docp::update"); + if (y->dim != _qp->b->dim || z->dim != _qp->d->dim) + error(E_SIZES, "Hqp_Docp::update"); + + c = v_get(1); + + fx = m_get(1, 1); + fu = m_get(1, 1); + cx = m_get(1, 1); + cu = m_get(1, 1); + Lxx = m_get(1, 1); + Luu = m_get(1, 1); + Lxu = m_get(1, 1); + vf = v_get(1); + vc = v_get(1); + + kxu = 0; + kf = 0; + _f = 0.0; + for (k = 0; k <= K; k++) { + nx = _nxs[k]; + nu = _nus[k]; + nf = _f_start[k+1] - _f_start[k]; + nc = _cns_start[k+1] - _cns_start[k]; + + v_part(_x, kxu, nx, _xk); + v_part(_x, kxu+nx, nu, _uk); + v_part(_qp->b, kf, nf, _fk); + c = v_resize(c, nc); + + v_part(_qp->c, kxu, nx, _s1); // f0x + v_part(_qp->c, kxu+nx, nu, _s2); // f0u + m_resize(fx, nf, nx); + m_resize(fu, nf, nu); + m_resize(cx, nc, nx); + m_resize(cu, nc, nu); + m_resize(Lxx, nx, nx); + m_resize(Luu, nu, nu); + m_resize(Lxu, nx, nu); + v_resize(vc, nc); + v_resize(vf, nf); + + // prepare value update + v_zero(_fk); + f0k = 0.0; + + // multiplier for system equations + for (i = 0; i < nf; i++) + vf[i] = y[kf + i]; + + // multiplier for general constraints + v_zero(vc); + _cns_ub->sv_mltadd_vec(k, -1.0, z, vc, _cns_start[k]); + _cns_lb->sv_mltadd_vec(k, 1.0, z, vc, _cns_start[k]); + _cns_eq->sv_mltadd_vec(k, 1.0, y, vc, _cns_start[k]); + + // extract the current Lagrangian Hessian for optional user update + sp_extract_mat(_qp->Q, kxu, kxu, Lxx); + sp_extract_mat(_qp->Q, kxu, kxu+nx, Lxu); + sp_extract_mat(_qp->Q, kxu+nx, kxu+nx, Luu); + + update_stage(_k0+k, _xk, _uk, + _fk, f0k, c, + fx, fu, _s1, _s2, cx, cu, + vf, vc, Lxx, Luu, Lxu); + + // value update + + v_sub(_fk, v_part(_x, kxu+nx+nu, nf, _xk), _fk); + + _f += f0k; + + // break if _f is not finite + if (!is_finite(_f)) + break; + + offs = _cns_start[k]; + v_ve = _qp->b->ve + _cns_eq->offs; + iend = _cns_eq->start[k+1]; + for (i = _cns_eq->start[k]; i < iend; i++) + v_ve[i] = c[_cns_eq->idxs[i]-offs] - _cns_eq->vals[i]; + + v_ve = _qp->d->ve + _cns_lb->offs; + iend = _cns_lb->start[k+1]; + for (i = _cns_lb->start[k]; i < iend; i++) + v_ve[i] = c[_cns_lb->idxs[i]-offs] - _cns_lb->vals[i]; + + v_ve = _qp->d->ve + _cns_ub->offs; + iend = _cns_ub->start[k+1]; + for (i = _cns_ub->start[k]; i < iend; i++) + v_ve[i] = _cns_ub->vals[i] - c[_cns_ub->idxs[i]-offs]; + + // derivatives update + + for (i = 0; i < nf; i++) + if (!_f_lin[kf+i]) { + sp_update_mrow(A, kf, kxu, fx, i); + sp_update_mrow(A, kf, kxu+nx, fu, i); + } + + _cns_eq->sp_update_mat(k, _qp->A, kxu, cx, _cns_start[k], _cns_lin); + _cns_lb->sp_update_mat(k, _qp->C, kxu, cx, _cns_start[k], _cns_lin); + sm_mlt(-1.0, cx, cx); + _cns_ub->sp_update_mat(k, _qp->C, kxu, cx, _cns_start[k], _cns_lin); + + _cns_eq->sp_update_mat(k, _qp->A, kxu+nx, cu, _cns_start[k], _cns_lin); + _cns_lb->sp_update_mat(k, _qp->C, kxu+nx, cu, _cns_start[k], _cns_lin); + sm_mlt(-1.0, cu, cu); + _cns_ub->sp_update_mat(k, _qp->C, kxu+nx, cu, _cns_start[k], _cns_lin); + + sp_update_mat(_qp->Q, kxu, kxu, Lxx); + sp_update_mat(_qp->Q, kxu+nx, kxu+nx, Luu); + sp_update_mat(_qp->Q, kxu, kxu+nx, Lxu); + + kf += nf; + kxu += nx+nu; + } + + // update state/control bounds and initial/final states + update_bounds(); + + v_free(c); + m_free(fx); + m_free(fu); + m_free(cx); + m_free(cu); + m_free(Lxx); + m_free(Luu); + m_free(Lxu); + v_free(vc); + v_free(vf); +} + +//------------------------------------------------------------------------- +// update_stage: +// -- default implementation calls update_vals(), +// update_grds(), and update_hela() +// +void Hqp_Docp::update_stage(int k, const VECP x, const VECP u, + VECP f, Real &f0, VECP c, + MATP fx, MATP fu, VECP f0x, VECP f0u, + MATP cx, MATP cu, + const VECP vf, const VECP vc, + MATP Lxx, MATP Luu, MATP Lxu) +{ + update_vals(k, x, u, f, f0, c); + update_grds(k, x, u, fx, fu, f0x, f0u, cx, cu); + update_hela(k, x, u, vf, vc, Lxx, Luu, Lxu); +} + +//------------------------------------------------------------------------- +// update_grds: +// -- default implementation approximates finite differences +// +void Hqp_Docp::update_grds(int k, const VECP x, const VECP u, + MATP fx, MATP fu, VECP f0x, VECP f0u, + MATP cx, MATP cu) +{ + int i, j; + int nx, nu, nf, nc; + Real vi_bak, dvi; + Real f0, df0; + VECP f, df; + VECP c, dc; + + nx = x->dim; + nu = u->dim; + nf = fx->m; + nc = cx->m; + + c = v_get(1); + dc = v_get(1); + f = v_get(1); + df = v_get(1); + + v_resize(c, nc); + v_resize(dc, nc); + v_resize(f, nf); + v_resize(df, nf); + + v_zero(f); + f0 = 0.0; + v_zero(c); + + update_vals(k, x, u, f, f0, c); + + for (i = 0; i < nx; i++) { + vi_bak = x->ve[i]; + dvi = 1e-4 * fabs(vi_bak) + 1e-6; + x->ve[i] += dvi; + + v_zero(df); + df0 = 0.0; + v_zero(dc); + + update_vals(k, x, u, df, df0, dc); + + v_sub(df, f, df); + for (j = 0; j < nf; j++) + fx->me[j][i] = df->ve[j] / dvi; + + f0x->ve[i] = (df0 - f0) / dvi; + + v_sub(dc, c, dc); + for (j = 0; j < nc; j++) + cx->me[j][i] = dc->ve[j] / dvi; + + x->ve[i] = vi_bak; + } + for (i = 0; i < nu; i++) { + vi_bak = u->ve[i]; + dvi = 1e-4 * fabs(vi_bak) + 1e-6; + u->ve[i] += dvi; + + v_zero(df); + df0 = 0.0; + v_zero(dc); + + update_vals(k, x, u, df, df0, dc); + + v_sub(df, f, df); + for (j = 0; j < nf; j++) + fu->me[j][i] = df->ve[j] / dvi; + + f0u->ve[i] = (df0 - f0) / dvi; + + v_sub(dc, c, dc); + for (j = 0; j < nc; j++) + cu->me[j][i] = dc->ve[j] / dvi; + + u->ve[i] = vi_bak; + } + + v_free(f); + v_free(df); + v_free(c); + v_free(dc); +} + +//------------------------------------------------------------------------- +void Hqp_Docp::update_hela(int, const VECP, const VECP, + const VECP, const VECP, + MATP, MATP, MATP) +{ + // empty default implementation, i.e. + // update provided by SQP solver must be used +} + + +//========================================================================= diff --git a/hqp/Hqp_Docp.h b/hqp/Hqp_Docp.h new file mode 100644 index 0000000..52b2cc3 --- /dev/null +++ b/hqp/Hqp_Docp.h @@ -0,0 +1,170 @@ +/* + * Hqp_Docp.h -- + * -- superclass: Hqp_SqpProgram + * -- superclass for formulating Discrete time Optimal Control Programs + * rf, 11/12/94 + * + * rf, 9/15/96 + * -- introduce update_stage() for vals, grds, and hela + * -- separate update_bounds() + * + * rf, 1/31/97 + * -- variable number of states/controls per stage + * + * rf, 11/01/00 + * -- introduce new virtual method setup_horizon + * -- delete method init_vars + * (introduce additional arguments to setup_vars instead) + * -- provide default implementation for method init_simulation + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_Docp_H +#define Hqp_Docp_H + +#include + +#include "Hqp_SqpProgram.h" + +class Hqp_DocpAssoc; + +//-------------------------------------- +class Hqp_Docp: public Hqp_SqpProgram { + + public: + + Hqp_Docp(); + ~Hqp_Docp(); + + void horizon(int k0, int kf); + + // types of states for automatic setup of constraints + static const int Periodical; // equal initial and final states + + void setup(); // init task for given _k0 and _kf + void init_x(); // set start variables + + int simulate(IF_DEF_ARGS); // perform a simulation for current _x + + // provide abstract interface for an optimal control task + // (default implementation of update_grds() uses finite differences) + //------------------------------------------------------------------ + virtual void setup_horizon(int &k0, int &kf); + + virtual void setup_vars(int k, + VECP x, VECP xmin, VECP xmax, + VECP u, VECP umin, VECP umax, + VECP c, VECP cmin, VECP cmax) = 0; + + virtual void setup_struct(int k, + VECP f0x, VECP f0u, int &f0_lin, + MATP fx, MATP fu, IVECP f_lin, + MATP cx, MATP cu, IVECP c_lin, + MATP Lxx, MATP Luu, MATP Lxu); + + virtual void init_simulation(int k, + VECP x, VECP u); + + virtual void update_vals(int k, const VECP x, const VECP u, + VECP f, Real &f0, VECP c) = 0; + + virtual void update_grds(int k, const VECP x, const VECP u, + MATP fx, MATP fu, VECP f0x, VECP f0u, + MATP cx, MATP cu); + + virtual void update_hela(int k, const VECP x, const VECP u, + const VECP vx, const VECP vc, + MATP Lxx, MATP Luu, MATP Lxu); + + virtual void update_stage(int k, const VECP x, const VECP u, + VECP f, Real &f0, VECP c, + MATP fx, MATP fu, VECP f0x, VECP f0u, + MATP cx, MATP cu, + const VECP rf, const VECP rc, + MATP Lxx, MATP Luu, MATP Lxu); + + // setup_vars() calls alloc_vars() to allocate variables and bounds + //---------------------------------------------------------------------- + void alloc_vars(VECP v, VECP vmin, VECP vmax, int n); + + private: + + int _k0; + int _kf; + VECP _xk; // subvector into _x + VECP _uk; // subvector into _x + VECP _fk; // subvector into _x + VECP _s1; // subvector 1 + VECP _s2; // subvector 2 + VEC _xk_head; + VEC _uk_head; + VEC _fk_head; + VEC _s1_head; + VEC _s2_head; + IVECP _x_type; + + int _fbd_evals; // number of function evaluation + + // implement methods to define a Hqp_SqpProgram + //--------------------------------------------- + void setup_x(); // called by setup() + void setup_qp(); // called by setup() + void update_fbd(); // update values + void update(const VECP y, const VECP z); // update all + void reinit_bd(); // re-initialize bounds + + void update_bounds(); // update state/control bounds and + // initial/final state constraints + + void parse_constr(const VECP cmin, const VECP cmax, + int idx, Hqp_DocpAssoc *eq, + Hqp_DocpAssoc *lb, Hqp_DocpAssoc *ub); + + // variables + //---------- + IVECP _nxs; // number of states per k + IVECP _nus; // number of controls per k + VECP _xus_init; // initial values for x and u per k + int _granul; // amount for growing _x_start during setup + + // objective + //---------- + IVECP _f0_lin; // mark linear objective terms + + // state/control bounds + //--------------------- + Hqp_DocpAssoc *_xu_eq; // equality constraints + Hqp_DocpAssoc *_xu_lb; // lower bounds + Hqp_DocpAssoc *_xu_ub; // upper bounds + IVECP _f_lin; // mark linear state equations + IVECP _f_start; // start indizes into _f_lin for each k + + // additional constraints + //----------------------- + Hqp_DocpAssoc *_cns_eq; // equality constraints + Hqp_DocpAssoc *_cns_lb; // lower bounds + Hqp_DocpAssoc *_cns_ub; // upper bounds + IVECP _cns_lin; // mark linear constraints + IVECP _cns_start; // start indizes into _cns_lin for each k +}; + + +#endif diff --git a/hqp/Hqp_DocpAdol.C b/hqp/Hqp_DocpAdol.C new file mode 100644 index 0000000..20dafed --- /dev/null +++ b/hqp/Hqp_DocpAdol.C @@ -0,0 +1,451 @@ +/* + * Hqp_DocpAdol.C -- + * -- class implementation + * + * rf, 12/29/95 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include + +#include + +#include + +#include "Hqp_DocpAdol.h" + + +//-------------------------------------------------------------------------- +static short** myalloc_short(int m, int n) +{ + short* Adum = (short*)malloc(m*n*sizeof(short)); + short** A = (short**)malloc(m*sizeof(short*)); + int i; + for(i=0;i _am || n > _an) { + adfree(); + adalloc(m, n); + } +} + +//-------------------------------------------------------------------------- +void Hqp_DocpAdol::horizon(int k0, int kmax) +{ + _k0 = k0; + _kmax = kmax; + Hqp_Docp::horizon(k0, kmax); +} + +//-------------------------------------------------------------------------- +void Hqp_DocpAdol::setup_struct(int k, + MATP fx, MATP fu, IVECP f_lin, + MATP cx, MATP cu, IVECP c_lin, + MATP Lxx, MATP Luu, MATP Lxu) +{ + if (!_static_struct || !_ad) + return; // initialize matrices to be dense + + // -- evaluate update_avals for recording, keep = 1 + // -- calculate Jacobians in reverse mode + // additionally, if the Lagrangian Hessian is required: + // -- exlude some trivial elements + // + + VECP xk = x(k); + VECP uk = u(k); + int xdim = xk->dim; + int udim = uk->dim; + int fdim = f_lin->dim; + int cdim = c_lin->dim; + adoublev ax(xdim); + adoublev au(udim); + adoublev af(fdim); + adouble af0; + adoublev ac(cdim); + int ndep, nindep; + int i, j, l, idx; + int maxdim; + VECP dumvec; + + maxdim = max(xdim, cdim); + maxdim = max(maxdim, udim); + maxdim = max(1, maxdim); + dumvec = v_get(maxdim); + + // obtain useful variable values + // !! store the result of update_avals() back to x(k+1) !! + init_solution(k, xk, uk); + + // record function evaluation + + trace_on(1, 1); // tape 1, keep = 1 for following reverse call + ax <<= xk->ve; + au <<= uk->ve; + + update_avals(k, ax, au, af, af0, ac); + + af0 >>= dumvec->ve[0]; + if (k < _kmax) + af >>= x(k+1)->ve; + else + af >>= dumvec->ve; + ac >>= dumvec->ve; + trace_off(); + + // calculate first derivatives using reverse + + ndep = 1 + fdim + cdim; + nindep = xdim + udim; + adresize(ndep, nindep); + + reverse(1, ndep, nindep, 0, _Z3, _nz); + + /* sparsity structure for f0x, f0u not yet required + for (j = 0; j < xdim; j++) + f0x[j] = _nz[0][j] == 0? 0.0: 1.0; + for (j = 0; j < udim; j++) + f0u[j] = _nz[0][xdim + j] == 0? 0.0: 1.0; + */ + + for (i = 0; i < fdim; i++) { + idx = 1 + i; + for (j = 0; j < xdim; j++) + fx[i][j] = _nz[idx][j] == 0? 0.0: 1.0; + for (j = 0; j < udim; j++) + fu[i][j] = _nz[idx][xdim + j] == 0? 0.0: 1.0; + } + + for (i = 0; i < cdim; i++) { + idx = 1 + fdim + i; + for (j = 0; j < xdim; j++) + cx[i][j] = _nz[idx][j] == 0? 0.0: 1.0; + for (j = 0; j < udim; j++) + cu[i][j] = _nz[idx][xdim + j] == 0? 0.0: 1.0; + } + +#if 0 + short nzij; + + // exclude all Lagrangian Hessian elements, + // where functions depend not or linearly from a variable + + // for each column of _nz: store the maximum of all rows in _nz[0] + for (j = 0; j < nindep; j++) { + nzij = _nz[0][j]; + for (i = 1; i < ndep; i++) + nzij = max(nzij, _nz[i][j]); + _nz[0][j] = nzij; + } + + for (i = 0; i < xdim; i++) + for (j = i + 1; j < xdim; j++) + if (_nz[0][i] < 2 || _nz[0][j] < 2) + Lxx[i][j] = 0.0; + + for (i = 0; i < udim; i++) + for (j = i + 1; j < udim; j++) + if (_nz[0][xdim + i] < 2 || _nz[0][xdim + j] < 2) + Luu[i][j] = 0.0; + + for (i = 0; i < xdim; i++) + for (j = 0; j < udim; j++) + if (_nz[0][i] < 2 || _nz[0][xdim + j] < 2) + Lxu[i][j] = 0.0; + +#else + + // insert all Lagrangian Hessian elements, + // where a function depends more than linearly from both variables + // associated with the indices + + m_zero(Lxx); + m_zero(Luu); + m_zero(Lxu); + + for (l = 0; l < ndep; l++) { + + for (i = 0; i < xdim; i++) + if (_nz[l][i] > 1) + for (j = i; j < xdim; j++) + if (_nz[l][j] > 1) + Lxx[i][j] = 1.0; + + for (i = 0; i < udim; i++) + if (_nz[l][xdim + i] > 1) + for (j = i; j < udim; j++) + if (_nz[l][xdim + j] > 1) + Luu[i][j] = 1.0; + + for (i = 0; i < xdim; i++) + if (_nz[l][i] > 1) + for (j = 0; j < udim; j++) + if (_nz[l][xdim + j] > 1) + Lxu[i][j] = 1.0; + } +#endif + + v_free(dumvec); +} + +//-------------------------------------------------------------------------- +void Hqp_DocpAdol::update_vals(int k, const VECP x, const VECP u, + VECP f, Real &f0, VECP c) +{ + // + // just evaluate update_avals + // + + adoublev ax(x->dim); + adoublev au(u->dim); + adoublev af(f->dim); + adouble af0; + adoublev ac(c->dim); + + af0 <<= f0; + + ax <<= x->ve; + au <<= u->ve; + + update_avals(k, ax, au, af, af0, ac); + + af0 >>= f0; + af >>= f->ve; + ac >>= c->ve; +} + +//-------------------------------------------------------------------------- +void Hqp_DocpAdol::update_stage(int k, const VECP x, const VECP u, + VECP f, Real &f0, VECP c, + MATP fx, MATP fu, VECP f0x, VECP f0u, + MATP cx, MATP cu, + const VECP rf, const VECP rc, + MATP Lxx, MATP Luu, MATP Lxu) +{ + if (!_ad) { + Hqp_Docp::update_stage(k, x, u, + f, f0, c, + fx, fu, f0x, f0u, cx, cu, + rf, rc, Lxx, Luu, Lxu); + return; + } + + // + // -- evaluate update_avals for recording, keep = 1 + // -- calculate Jacobians in reverse mode + // additionally, if the Lagrangian Hessian is required: + // repeat for each row: + // -- calculate forward with keep = 2 + // -- calculate second derivatives in reverse mode + // + + int xdim = x->dim; + int udim = u->dim; + int fdim = rf->dim; + int cdim = rc->dim; + adoublev ax(xdim); + adoublev au(udim); + adoublev af(fdim); + adouble af0; + adoublev ac(cdim); + int ndep, nindep; + int i, j, idx; + int ninfs; + double val; + + // record function evaluation + + af0 <<= f0; + + trace_on(1, 1); // tape 1, keep = 1 for following reverse call + ax <<= x->ve; + au <<= u->ve; + + update_avals(k, ax, au, af, af0, ac); + + af0 >>= f0; + af >>= f->ve; + ac >>= c->ve; + trace_off(); + + // calculate first derivatives using reverse + + ndep = 1 + fdim + cdim; + nindep = xdim + udim; + adresize(ndep, nindep); + + reverse(1, ndep, nindep, 0, _Z3); + + for (j = 0; j < xdim; j++) + f0x[j] = _Z3[0][j][0]; + for (j = 0; j < udim; j++) + f0u[j] = _Z3[0][xdim + j][0]; + + for (i = 0; i < fdim; i++) { + idx = 1 + i; + for (j = 0; j < xdim; j++) + fx[i][j] = _Z3[idx][j][0]; + for (j = 0; j < udim; j++) + fu[i][j] = _Z3[idx][xdim + j][0]; + } + + for (i = 0; i < cdim; i++) { + idx = 1 + fdim + i; + for (j = 0; j < xdim; j++) + cx[i][j] = _Z3[idx][j][0]; + for (j = 0; j < udim; j++) + cu[i][j] = _Z3[idx][xdim + j][0]; + } + + if (_hela) { + + // init weighting vector + _U[0][0] = 1.0; + j = 1; + for (i = 0; i < fdim; i++, j++) + _U[0][j] = -rf[i]; + for (i = 0; i < cdim; i++, j++) + _U[0][j] = -rc[i]; + + // init independent variable values + j = 0; + for (i = 0; i < xdim; i++, j++) { + _X[j][0] = x[i]; + _X[j][1] = 0.0; + } + for (i = 0; i < udim; i++, j++) { + _X[j][0] = u[i]; + _X[j][1] = 0.0; + } + + // calculate Lagrangian Hessian by rows + // (only the upper diagonal part) + + ninfs = 0; // count the number of infinite values + for (i = 0; i < nindep; i++) { + _X[i][1] = 1.0; + + forward(1, ndep, nindep, 1, 2, _X, _Y); + reverse(1, ndep, nindep, 1, _U[0], _Z); + + if (i < xdim) { + for (j = 0; j < xdim; j++) { + val = _Z[j][1]; + if (is_finite(val)) + Lxx[i][j] = val; + else + ninfs++; + } + for (j = 0; j < udim; j++) { + val = _Z[xdim + j][1]; + if (is_finite(val)) + Lxu[i][j] = val; + else + ninfs++; + } + } + else { + idx = i - xdim; + for (j = idx; j < udim; j++) { + val = _Z[xdim + j][1]; + if (is_finite(val)) + Luu[idx][j] = val; + else + ninfs++; + } + } + + _X[i][1] = 0.0; + } + + if (ninfs > 0) + fprintf(stderr, "%d infinite Lagrangian Hessian values!\n", ninfs); + + } +} + +//======================================================================== diff --git a/hqp/Hqp_DocpAdol.h b/hqp/Hqp_DocpAdol.h new file mode 100644 index 0000000..10831ca --- /dev/null +++ b/hqp/Hqp_DocpAdol.h @@ -0,0 +1,103 @@ +/* + * Hqp_DocpAdol.h -- + * -- discrete time optimal control problems with automatic differentiation + * using operator overloading + * + * Refences: + * E. Arnold: Hqp_Docp_Adol, personal communication + * + * A. Griewank, D. Juedes, and J. Utke: + * ADOL-C: A Package for the Automatic Differentiation of + * Algorithms Written in C/C++. + * rf, 12/19/95 + * + * rf, 9/15/96 + * -- replace update_ders() with update_stage() + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_DocpAdol_H +#define Hqp_DocpAdol_H + +#include "Hqp_Docp.h" + +#include + +//-------------------------------------------------------------------------- +class Hqp_DocpAdol: public Hqp_Docp { + + public: + + Hqp_DocpAdol(); + ~Hqp_DocpAdol(); + + void horizon(int k0, int kmax); + + // interface for overloding by a derived class + virtual void setup_constr(int k, + VECP xmin, VECP xmax, + VECP umin, VECP umax, + VECP cmin, VECP cmax) = 0; + virtual void init_solution(int k, + VECP x, VECP u) = 0; + virtual void update_avals(int k, + const adoublev &x, const adoublev &u, + adoublev &f, adouble &f0, adoublev &c) = 0; + + private: + + int _k0; + int _kmax; + int _static_struct; + int _hela; + int _ad; + + // arrays passed to Adol-C and their dimensions + int _am; // number of dependent variables + int _an; // number of independent variables + double **_X; + double **_Y; + double **_U; + double **_Z; + double ***_Z3; + short **_nz; + void adalloc(int m, int n); + void adfree(); + void adresize(int m, int n); + + // methods of Hqp_Docp, that are handled internally + // with the help of update_avals() and using Adol-C + void setup_struct(int k, + MATP fx, MATP fu, IVECP f_lin, + MATP cx, MATP cu, IVECP c_lin, + MATP Lxx, MATP Luu, MATP Lxu); + void update_vals(int k, const VECP x, const VECP u, + VECP f, Real &f0, VECP c); + void update_stage(int k, const VECP x, const VECP u, + VECP f, Real &f0, VECP c, + MATP fx, MATP fu, VECP f0x, VECP f0u, + MATP cx, MATP cu, + const VECP rf, const VECP rc, + MATP Lxx, MATP Luu, MATP Lxu); +}; + +#endif + diff --git a/hqp/Hqp_Docp_wrapper.h b/hqp/Hqp_Docp_wrapper.h new file mode 100644 index 0000000..93d6a13 --- /dev/null +++ b/hqp/Hqp_Docp_wrapper.h @@ -0,0 +1,154 @@ +/* + * Hqp_Docp_wrapper.h -- + * Implement an Hqp_Docp and connect it to Hqp_Docp_spec. + * + * rf, 10/31/00 + * + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_Docp_wrapper_H +#define Hqp_Docp_wrapper_H + +#include + +#include "Hqp_Docp.h" +#include "Hqp.h" + +//--------------------------------------- +class Hqp_Docp_wrapper: public Hqp_Docp { +public: + //---------------------------------------------------------- + Hqp_Docp_wrapper(Hqp_Docp_spec &spec, void *clientdata) + { + // check for mandatory functions + assert(spec.setup_horizon); + assert(spec.setup_vars); + assert(spec.update_vals); + + // initialize data + _spec = spec; + _clientdata = clientdata; + + // export reference to this object + extern Hqp_SqpProgram *theSqpProgram; + theSqpProgram = this; + } + + //---------------------------------------------------------- + ~Hqp_Docp_wrapper() + { + // clear reference to this object + extern Hqp_SqpProgram *theSqpProgram; + if (theSqpProgram == this) + theSqpProgram = NULL; + } + + // implement interface of Hqp_Docp by calling Hqp_Docp_spec + //---------------------------------------------------------- + void setup_horizon(int &k0, int &kf) + { + (*_spec.setup_horizon)(_clientdata, k0, kf); + } + + //---------------------------------------------------------- + void setup_vars(int k, + VECP x, VECP xmin, VECP xmax, + VECP u, VECP umin, VECP umax, + VECP c, VECP cmin, VECP cmax) + { + (*_spec.setup_vars)(_clientdata, k, + x, xmin, xmax, + u, umin, umax, + c, cmin, cmax); + } + + //---------------------------------------------------------- + void setup_struct(int k, + VECP f0x, VECP f0u, int &f0_lin, + MATP fx, MATP fu, IVECP f_lin, + MATP cx, MATP cu, IVECP c_lin, + MATP Lxx, MATP Luu, MATP Lxu) + { + if (_spec.setup_struct) { + (*_spec.setup_struct)(_clientdata, k, + f0x, f0u, f0_lin, + fx, fu, f_lin, + cx, cu, c_lin, + Lxx, Luu, Lxu); + } + else { + Hqp_Docp::setup_struct(k, + f0x, f0u, f0_lin, + fx, fu, f_lin, + cx, cu, c_lin, + Lxx, Luu, Lxu); + } + } + + //---------------------------------------------------------- + void init_simulation(int k, VECP x, VECP u) + { + if (_spec.init_simulation) { + (*_spec.init_simulation)(_clientdata, k, x, u); + } + else { + Hqp_Docp::init_simulation(k, x, u); + } + } + + //---------------------------------------------------------- + void update_vals(int k, const VECP x, const VECP u, + VECP f, double &f0, VECP c) + { + (*_spec.update_vals)(_clientdata, k, x, u, f, f0, c); + } + + //---------------------------------------------------------- + void update_stage(int k, const VECP x, const VECP u, + VECP f, double &f0, VECP c, + MATP fx, MATP fu, VECP f0x, VECP f0u, + MATP cx, MATP cu, + const VECP rf, const VECP rc, + MATP Lxx, MATP Luu, MATP Lxu) + { + if (_spec.update_stage) { + (*_spec.update_stage)(_clientdata, k, x, u, f, f0, c, + fx, fu, f0x, f0u, cx, cu, + rf, rc, Lxx, Luu, Lxu); + } + else { + Hqp_Docp::update_stage(k, x, u, f, f0, c, + fx, fu, f0x, f0u, cx, cu, + rf, rc, Lxx, Luu, Lxu); + } + } + + //---------------------------------------------------------- + char *name() {return "Docp_wrapper";} + +protected: + Hqp_Docp_spec _spec; + void *_clientdata; +}; + + +#endif diff --git a/hqp/Hqp_DynLoad.C b/hqp/Hqp_DynLoad.C new file mode 100644 index 0000000..d4c3ad5 --- /dev/null +++ b/hqp/Hqp_DynLoad.C @@ -0,0 +1,70 @@ +/* + * Hqp_DynLoad.C + * -- implementation + * + * rf, 3/13/97 + * + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include "Hqp_DynLoad.h" +#include + +//------------------------------------------------------------------------ +Hqp_DynLoad::Hqp_DynLoad() +{ + _handle = 0; +} + +//------------------------------------------------------------------------ +Hqp_DynLoad::~Hqp_DynLoad() +{ + if (_handle) + close(); +} + +//------------------------------------------------------------------------ +bool Hqp_DynLoad::open(const char *pathname) +{ + _handle = dlopen(pathname, RTLD_LAZY); + return _handle? true: false; +} + +//------------------------------------------------------------------------ +void *Hqp_DynLoad::symbol(const char *name) +{ + return dlsym(_handle, name); +} + +//------------------------------------------------------------------------ +const char *Hqp_DynLoad::errmsg() +{ + return dlerror(); +} + +//------------------------------------------------------------------------ +void Hqp_DynLoad::close() +{ + dlclose(_handle); +} + + +//======================================================================== diff --git a/hqp/Hqp_DynLoad.h b/hqp/Hqp_DynLoad.h new file mode 100644 index 0000000..8c1b907 --- /dev/null +++ b/hqp/Hqp_DynLoad.h @@ -0,0 +1,47 @@ +/* + * Hqp_DynLoad.h + * -- dynamically load symbols + * + * rf, 3/13/97 + * + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_DynLoad_H +#define Hqp_DynLoad_H + +class Hqp_DynLoad { + +protected: + void *_handle; + +public: + Hqp_DynLoad(); + ~Hqp_DynLoad(); + + bool open(const char *pathname); + void *symbol(const char *name); + const char *errmsg(); + void close(); +}; + + +#endif diff --git a/hqp/Hqp_HL.C b/hqp/Hqp_HL.C new file mode 100644 index 0000000..67cef2c --- /dev/null +++ b/hqp/Hqp_HL.C @@ -0,0 +1,223 @@ +/* + * Hqp_HL.C -- + * - class definition + * + * rf, 7/19/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include + +#include +#include + +#include "Hqp_HL.h" +#include "Hqp_Program.h" +#include "Hqp_SqpProgram.h" + +IF_BASE_DEFINE(Hqp_HL); + +//-------------------------------------------------------------------------- +Hqp_HL::Hqp_HL() +{ + _scale = true; + _eps = 1e-8; + _logging = false; + + _rowsum = v_resize(v_get(1), 0); + + _ifList.append(new If_Bool("sqp_hela_scale", &_scale)); + _ifList.append(new If_Bool("sqp_hela_logging", &_logging)); + _ifList.append(new If_Float("sqp_hela_eps", &_eps)); +} + +//-------------------------------------------------------------------------- +Hqp_HL::~Hqp_HL() +{ + v_free(_rowsum); +} + +//-------------------------------------------------------------------------- +static double dxi(double xi) +{ + return fabs(1e-4 * xi) + 1e-6; +} + +//-------------------------------------------------------------------------- +void Hqp_HL::init(const VEC *y, const VEC *z, Hqp_SqpProgram *prg) +{ + if (sp_norm_inf(prg->qp()->Q) > _eps) { + // assume a user-specified Lagrangian Hessian + posdef(prg); + return; + } + + Hqp_Program *qp = prg->qp(); + Real f_bak; + VEC *c_bak=VNULL, *x_bak=VNULL; + VEC *b_bak=VNULL, *d_bak=VNULL; + SPMAT *A_bak, *C_bak; + VEC *dx, *x_mod, *dgL, *gL; + int i, n = qp->c->dim; + Real val; + + if (!_scale) { + sp_ident(prg->qp()->Q); + } + else { + f_bak = prg->f(); + x_bak = v_copy(prg->x(), x_bak); + b_bak = v_copy(qp->b, b_bak); + d_bak = v_copy(qp->d, d_bak); + c_bak = v_copy(qp->c, c_bak); + A_bak = qp->A; + qp->A = sp_copy(A_bak); + C_bak = qp->C; + qp->C = sp_copy(C_bak); + + dx = v_get(n); + x_mod = v_get(n); + dgL = v_get(n); + gL = v_get(n); + + gL = grd_L(y, z, qp, gL); + + dx = v_map(&dxi, prg->x(), dx); + v_add(x_bak, dx, x_mod); + prg->x(x_mod); + prg->update((VEC *)y, (VEC *)z); + dgL = grd_L(y, z, qp, dgL); + dgL = v_sub(dgL, gL, dgL); + + sp_zero(qp->Q); + for (i=0; ive[i] / dx->ve[i]; + sp_set_val(qp->Q, i, i, max(val, _eps)); + } + + prg->f(f_bak); + prg->x(x_bak); + v_copy(b_bak, qp->b); + v_copy(d_bak, qp->d); + v_copy(c_bak, qp->c); + + sp_free(qp->A); + qp->A = A_bak; + sp_free(qp->C); + qp->C = C_bak; + + v_free(b_bak); + v_free(d_bak); + v_free(c_bak); + v_free(x_bak); + v_free(dgL); + v_free(x_mod); + v_free(dx); + v_free(gL); + } +} + +//-------------------------------------------------------------------------- +void Hqp_HL::posdef(Hqp_SqpProgram *prg) +{ + SPMAT *Q; + SPROW *row; + row_elt *elt; + Real *rs_ve, val; + int i, i_end; + int j, j_idx, j_end; + + // ensure positive definiteness with diagonal offsets + // (works for upper diagonal matrices) + Q = prg->qp()->Q; + + if (!Q->flag_diag) + sp_diag_access(Q); + + v_resize(_rowsum, Q->m); + v_zero(_rowsum); + row = Q->row; + rs_ve = _rowsum->ve; + i_end = Q->m; + for (i = 0; i < i_end; i++, row++) { + j_end = row->len; + j_idx = row->diag + 1; + if (j_idx <= 0) { + // there must always be a diagonal entry + error(E_INTERN, "Hqp_HL::posdef"); + } + elt = row->elt + j_idx; + for (; j_idx < j_end; j_idx++, elt++) { + j = elt->col; + val = fabs(elt->val); + rs_ve[i] += val; + rs_ve[j] += val; + } + } + + row = Q->row; + for (i = 0; i < i_end; i++, row++, rs_ve++) { + elt = row->elt + row->diag; + elt->val = max(elt->val, *rs_ve + _eps); + } + +/* + // ensure positive definiteness + Q = prg->qp()->Q; + i_end = Q->m; + for (i=0; irow[i].len; + elt = Q->row[i].elt; + diag_elt = NULL; + for (j_idx=0; j_idxcol != i) + rowsum += fabs(elt->val); + else + diag_elt = elt; + } + assert(diag_elt); + diag_elt->val = max(diag_elt->val, rowsum + _eps); + } +*/ +} + +//-------------------------------------------------------------------------- +VEC *Hqp_HL::grd_L(const VEC *y, const VEC *z, const Hqp_Program *qp, + VEC *out) +{ + int n = qp->Q->m; + + if (!out || (int)out->dim != n) { + out = v_resize(out, n); + } + + // calculate gradient of Lagrangian + v_zero(out); + sp_vm_mltadd(out, y, qp->A, 1.0, out); + sp_vm_mltadd(out, z, qp->C, 1.0, out); + v_sub(qp->c, out, out); + + return out; +} + + +//========================================================================== diff --git a/hqp/Hqp_HL.h b/hqp/Hqp_HL.h new file mode 100644 index 0000000..d1ed565 --- /dev/null +++ b/hqp/Hqp_HL.h @@ -0,0 +1,76 @@ +/* + * Hqp_HL.h -- + * - base class for approximating sparse Hessian of Lagrangian + * + * rf, 7/19/94 + * + * rf, 9/15/96 + * - extended init() to additionally backup f, b, d + * + * rf, 2/13/97 + * - new method posdef() that performs Gerschgorin modification + * + * rf, 2/18/98 + * - update_Q() gets sqp_alpha as additional argument + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_HL_H +#define Hqp_HL_H + +#include +#include + +#include "Hqp_impl.h" + +IF_BASE_DECLARE(Hqp_HL); + +class Hqp_Program; +class Hqp_SqpProgram; + +class Hqp_HL { + + protected: + If_List _ifList; + bool _scale; + Real _eps; // ensure positive definiteness + bool _logging; // print status messages + VEC *_rowsum; + + VEC *grd_L(const VEC *y, const VEC *z, const Hqp_Program *qp, + VEC *out); + + public: + Hqp_HL(); + virtual ~Hqp_HL(); + + virtual void setup(Hqp_SqpProgram *) = 0; + virtual void init(const VEC *y, const VEC *z, Hqp_SqpProgram *); + virtual void update(const VEC *s, const VEC *u, Real alpha, + Hqp_SqpProgram *) = 0; + + virtual void posdef(Hqp_SqpProgram *); + + virtual char *name() = 0; +}; + + +#endif diff --git a/hqp/Hqp_HL_AugBFGS.C b/hqp/Hqp_HL_AugBFGS.C new file mode 100644 index 0000000..811cae0 --- /dev/null +++ b/hqp/Hqp_HL_AugBFGS.C @@ -0,0 +1,329 @@ +/* + * Hqp_HL_AugBFGS.C -- + * - class definition + * + * rf, 7/19/94 + * + * rf, 2/13/97 + * - consider an initial Hessian already given in init() + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +extern "C" { +#include +} +#include +#include + +#include "Hqp_HL_AugBFGS.h" +#include "Hqp_Program.h" +#include "Hqp_SqpProgram.h" + +IF_CLASS_DEFINE("AugBFGS", Hqp_HL_AugBFGS, Hqp_HL); + +//-------------------------------------------------------------------------- +Hqp_HL_AugBFGS::Hqp_HL_AugBFGS() +{ + _v = VNULL; + _sQ = VNULL; + _Qs = VNULL; + _b_Q = m_get(1, 1); + + _gamma = 0.2; + _bsize = -1; + _max_bsize = -1; + + _ifList.append(new If_Float("sqp_hela_gamma", &_gamma)); + _ifList.append(new If_Int("sqp_hela_bsize", &_bsize)); + _ifList.append(new If_Int("sqp_hela_max_bsize", &_max_bsize)); +} + +//-------------------------------------------------------------------------- +Hqp_HL_AugBFGS::~Hqp_HL_AugBFGS() +{ + v_free(_v); + v_free(_sQ); + v_free(_Qs); + m_free(_b_Q); +} + +//-------------------------------------------------------------------------- +void Hqp_HL_AugBFGS::setup(Hqp_SqpProgram *prg) +{ + SPMAT *Q = prg->qp()->Q; + int offs, size, old_size; + MAT *b_Q_ones; + + // allocate entries for the block-diagonal structure + + _b_begin = 0; + old_size = _b_Q->n; + b_Q_ones = m_get(old_size, old_size); + m_ones(b_Q_ones); + _max_bsize = -1; + + while(next_block(Q, &offs, &size)) { + _max_bsize = max(_max_bsize, size); + if (size != old_size) { + _b_Q = m_resize(_b_Q, size, size); + b_Q_ones = m_resize(b_Q_ones, size, size); + m_ones(b_Q_ones); + old_size = size; + } + symsp_extract_mat(Q, offs, _b_Q); + symsp_insert_symmat(Q, offs, b_Q_ones); // allocate entries + sp_update_mat(Q, offs, offs, _b_Q); + } + + m_free(b_Q_ones); +} + +#if 0 +//-------------------------------------------------------------------------- +static void restart_Q(MAT *Q, Real eps) +{ + Real m_norm; + + m_norm = m_norm_inf(Q); + m_norm = max(m_norm, eps); + m_norm = min(m_norm, 1.0/eps); + m_ident(Q); + sm_mlt(m_norm, Q, Q); +} +#else +//-------------------------------------------------------------------------- +static void restart_Q(MAT *Q, Real eps) +{ + int i, j, dim; + Real row_max, val; + Real *Q_re; + + dim = Q->m; + if (dim < 1) + return; + + for (i = 0; i < dim; i++) { + Q_re = Q->me[i]; + row_max = eps; + for (j = 0; j < dim; j++) { + val = fabs(Q_re[j]); + row_max = max(row_max, val); + Q_re[j] = 0.0; + } + row_max = min(row_max, 1.0/eps); + Q_re[i] = row_max; + } +} +#endif + +//-------------------------------------------------------------------------- +void Hqp_HL_AugBFGS::update_b_Q(const VEC *s, const VEC *u, Real alpha, + MAT *Q) +{ + Real sv, sQs; + Real theta; + Real *v_ve, *Qs_ve, *sQ_ve, *Q_re; + int i, i_end; + int j, j_end; + + Real beta, lambda, sum_s4, omega_i; + + sv = in_prod(s, u); + + _sQ = vm_mlt(Q, s, _sQ); // Q has lower and upper diagonal parts + _Qs = mv_mlt(Q, s, _Qs); + sQs = in_prod(_sQ, s); + + double rowsum; + if (sQs < 0.0) { + // apply Gerschgorin + fprintf(stderr, "Hela-Bingo: %g --> ", sQs); + i_end = Q->m; + for (i = 0; i < i_end; i++) { + rowsum = 0.0; + for (j = 0; j < i; j++) + rowsum += fabs(Q->me[j][i]); + for (j = i+1; j < j_end; j++) + rowsum += fabs(Q->me[i][j]); + Q->me[i][i] = max(Q->me[i][i], rowsum); + } + _sQ = vm_mlt(Q, s, _sQ); // Q has lower and upper diagonal parts + _Qs = mv_mlt(Q, s, _Qs); + sQs = in_prod(_sQ, s); + fprintf(stderr, "%g\n", sQs); + } + +#if 0 + // augmentation + if (0 && sv < _gamma * sQs) { + v_ve = s->ve; + i_end = Q->m; + sum_s4 = 0.0; + for (i = 0; i < i_end; i++) { + sum_s4 += v_ve[i] * v_ve[i] * v_ve[i] * v_ve[i]; + } + beta = _gamma * sQs - sv; + lambda = beta / sum_s4; + for (i = 0; i < i_end; i++) { + omega_i = lambda * v_ve[i] * v_ve[i]; + _v->ve[i] = u->ve[i] + omega_i * v_ve[i]; + } + sv = in_prod(s, _v); + } + else { + _v = v_copy(u, _v); + } +#endif + + _gamma = 0.1 + 0.9 * (1.0 - alpha); + // Powells correcture + if (sv < _gamma * sQs) { + theta = (1.0 - _gamma) * sQs / (sQs - sv); + _v = sv_mlt(theta, u, _v); + v_mltadd(_v, _Qs, 1.0 - theta, _v); + sv = in_prod(s, _v); + } + else { + _v = v_copy(u, _v); + } + + if (!(sv != 0.0) && (sQs != 0.0)) + fprintf(stderr, "Hela-Bingo deficiency: %g, %g\n", sv, sQs); + + if (!(sv != 0.0) || !(sQs != 0.0)) + return; + + v_ve = _v->ve; + sQ_ve = _sQ->ve; + Qs_ve = _Qs->ve; + i_end = Q->m; + j_end = Q->n; + for (i = 0; i < i_end; i++) { + Q_re = Q->me[i]; + for (j = i; j < j_end; j++) { // update upper diagonal part + Q_re[j] -= Qs_ve[i] * sQ_ve[j] / sQs; + Q_re[j] += v_ve[i] * v_ve[j] / sv; + Q->me[j][i] = Q_re[j]; // update lower diagonal part + } + } + + theta = _eps * _eps; + if (sQs < theta && sQs >= 0.0) + theta = sQs; + _sQ = symmeig(Q, MNULL, _sQ); + sQs = v_min(_sQ, NULL); + sQs -= theta; + if (sQs < 0.0) { + for (i = 0; i < i_end; i++) + Q->me[i][i] -= sQs; + /* + fprintf(stderr, "Eigenvalues: %g .. %g --> ", + v_min(_sQ, NULL), v_max(_sQ, NULL)); + _sQ = symmeig(Q, MNULL, _sQ); + fprintf(stderr, "%g .. %g\n", + v_min(_sQ, NULL), v_max(_sQ, NULL)); + */ + } + +#if 0 + for (i = 0; i < i_end; i++) { + rowsum = 0.0; + for (j = 0; j < i; j++) + rowsum += fabs(Q->me[j][i]); + for (j = i+1; j < j_end; j++) + rowsum += fabs(Q->me[i][j]); + Q->me[i][i] = max(Q->me[i][i], rowsum); + } +#endif +} + +//-------------------------------------------------------------------------- +void Hqp_HL_AugBFGS::update(const VEC *s, const VEC *u, Real alpha, + Hqp_SqpProgram *prg) +{ + SPMAT *Q = prg->qp()->Q; + VEC b_s, b_u; + int offs, size; + + b_u.max_dim = 0; + b_s.max_dim = 0; + b_u.dim = _b_Q->n; + b_s.dim = _b_Q->n; + + _b_begin = 0; + + while(next_block(Q, &offs, &size)) { + if (size != (int)b_u.dim) { + b_u.dim = size; + b_s.dim = size; + _b_Q = m_resize(_b_Q, size, size); + } + symsp_extract_mat(Q, offs, _b_Q); // build lower and upper diagonal parts + b_u.ve = u->ve + offs; + b_s.ve = s->ve + offs; + update_b_Q(&b_s, &b_u, alpha, _b_Q); + symsp_insert_symmat(Q, offs, _b_Q); // insert upper diagonal part + } +} + +//-------------------------------------------------------------------------- +// next_block: +// find next diagonal block in Q, starting with index _b_begin +//-------------------------------------------------------------------------- +int Hqp_HL_AugBFGS::next_block(const SPMAT *Q, int *offs, int *size) +{ + int b_end, max_col; + SPROW *row; + + if (_b_begin >= Q->m) + return 0; + + *offs = _b_begin; + + // _bsize < 0: automatic detection of the block size + // _bsize = 0: full Hessian + // _bsize > 0: block of dimension _bsize + + if (_bsize < 0) { + b_end = _b_begin; + while (_b_begin <= b_end) { + row = &(Q->row[_b_begin]); + if (row->len > 0) + max_col = row->elt[row->len - 1].col; + else + max_col = _b_begin; + b_end = max(b_end, max_col); + _b_begin ++; + } + *size = b_end - *offs + 1; + } + else { + *size = Q->n - _b_begin; + if (_bsize > 0) + *size = min(_bsize, *size); + _b_begin += *size; + } + + return 1; +} + +//========================================================================= diff --git a/hqp/Hqp_HL_AugBFGS.h b/hqp/Hqp_HL_AugBFGS.h new file mode 100644 index 0000000..20f031a --- /dev/null +++ b/hqp/Hqp_HL_AugBFGS.h @@ -0,0 +1,62 @@ +/* + * Hqp_HL_AugBFGS.h -- + * - experimental BFGS Hessian approximation with Powell's modification + * - computes a separate update for every diagonal block + * + * rf, 2/18/98 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_HL_AugBFGS_H +#define Hqp_HL_AugBFGS_H + +#include "Hqp_HL.h" + + +class Hqp_HL_AugBFGS: public Hqp_HL { + + protected: + Real _gamma; + int _bsize; + int _max_bsize; + + VEC *_v; + VEC *_sQ; + VEC *_Qs; + + MAT *_b_Q; + int _b_begin; + + void update_b_Q(const VEC *s, const VEC *u, Real alpha, MAT *Q); + int next_block(const SPMAT *, int *offs, int *size); + + public: + Hqp_HL_AugBFGS(); + ~Hqp_HL_AugBFGS(); + + void setup(Hqp_SqpProgram *); + void update(const VEC *s, const VEC *u, Real alpha, Hqp_SqpProgram *); + + char *name() {return "AugBFGS";} +}; + + +#endif diff --git a/hqp/Hqp_HL_BFGS.C b/hqp/Hqp_HL_BFGS.C new file mode 100644 index 0000000..c98a685 --- /dev/null +++ b/hqp/Hqp_HL_BFGS.C @@ -0,0 +1,293 @@ +/* + * Hqp_HL_BFGS.C -- + * - class definition + * + * rf, 7/19/94 + * + * rf, 2/13/97 + * - consider an initial Hessian already given in init() + * + * rf, 4/13/99 + * - change eigen_control default to false, + * (because Meschach's symmeig() may have endless iteration) + * rf, 10/27/00 + * - change eigen_control default to true again (+bug fix in Meschach) + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +extern "C" { +#include +} + +#include +#include +#include + +#include "Hqp_HL_BFGS.h" +#include "Hqp_Program.h" +#include "Hqp_SqpProgram.h" + +IF_CLASS_DEFINE("BFGS", Hqp_HL_BFGS, Hqp_HL); + +//-------------------------------------------------------------------------- +Hqp_HL_BFGS::Hqp_HL_BFGS() +{ + _v = VNULL; + _sQ = VNULL; + _Qs = VNULL; + _b_Q = m_get(1, 1); + + _gamma = 0.1; + _eigen_control = true; + _bsize = -1; + _max_bsize = -1; + + _ifList.append(new If_Float("sqp_hela_gamma", &_gamma)); + _ifList.append(new If_Bool("sqp_hela_eigen_control", &_eigen_control)); + _ifList.append(new If_Int("sqp_hela_bsize", &_bsize)); + _ifList.append(new If_Int("sqp_hela_max_bsize", &_max_bsize)); +} + +//-------------------------------------------------------------------------- +Hqp_HL_BFGS::~Hqp_HL_BFGS() +{ + v_free(_v); + v_free(_sQ); + v_free(_Qs); + m_free(_b_Q); +} + +//-------------------------------------------------------------------------- +void Hqp_HL_BFGS::setup(Hqp_SqpProgram *prg) +{ + SPMAT *Q = prg->qp()->Q; + int offs, size, old_size; + MAT *b_Q_ones; + + // allocate entries for the block-diagonal structure + + _b_begin = 0; + old_size = _b_Q->n; + b_Q_ones = m_get(old_size, old_size); + m_ones(b_Q_ones); + _max_bsize = -1; + + while(next_block(Q, &offs, &size)) { + _max_bsize = max(_max_bsize, size); + if (size != old_size) { + _b_Q = m_resize(_b_Q, size, size); + b_Q_ones = m_resize(b_Q_ones, size, size); + m_ones(b_Q_ones); + old_size = size; + } + symsp_extract_mat(Q, offs, _b_Q); + symsp_insert_symmat(Q, offs, b_Q_ones); // allocate entries + sp_update_mat(Q, offs, offs, _b_Q); + } + + m_free(b_Q_ones); +} + +#if 0 +//-------------------------------------------------------------------------- +static void restart_Q(MAT *Q, Real eps) +{ + Real m_norm; + + m_norm = m_norm_inf(Q); + m_norm = max(m_norm, eps); + m_norm = min(m_norm, 1.0/eps); + m_ident(Q); + sm_mlt(m_norm, Q, Q); +} +#else +//-------------------------------------------------------------------------- +static void restart_Q(MAT *Q, Real eps) +{ + int i, j, dim; + Real row_max, val; + Real *Q_re; + + dim = Q->m; + if (dim < 1) + return; + + for (i = 0; i < dim; i++) { + Q_re = Q->me[i]; + row_max = eps; + for (j = 0; j < dim; j++) { + val = fabs(Q_re[j]); + row_max = max(row_max, val); + Q_re[j] = 0.0; + } + row_max = min(row_max, 1.0/eps); + Q_re[i] = row_max; + } +} +#endif + +//-------------------------------------------------------------------------- +void Hqp_HL_BFGS::update_b_Q(const VEC *s, const VEC *u, Real alpha, MAT *Q) +{ + Real sv, sQs; + Real theta, gamma; + Real *v_ve, *Qs_ve, *sQ_ve, *Q_re; + int i, i_end; + int j, j_end; + + sv = in_prod(s, u); + + _sQ = vm_mlt(Q, s, _sQ); // Q has lower and upper diagonal parts + _Qs = mv_mlt(Q, s, _Qs); + sQs = in_prod(_sQ, s); + + if (_gamma >= 0.0) { + // standard damping + gamma = _gamma; + } + else { + // damping adapted to step length + gamma = -_gamma; + gamma = gamma + (1.0 - gamma) * (1.0 - alpha); + } + + // Powells modification + if (sv < gamma * sQs) { + theta = (1.0 - gamma) * sQs / (sQs - sv); + _v = sv_mlt(theta, u, _v); + v_mltadd(_v, _Qs, 1.0 - theta, _v); + sv = in_prod(s, _v); + } + else { + _v = v_copy(u, _v); + } + + if (!(sv != 0.0) || !(sQs != 0.0)) + return; + + v_ve = _v->ve; + sQ_ve = _sQ->ve; + Qs_ve = _Qs->ve; + i_end = Q->m; + j_end = Q->n; + for (i = 0; i < i_end; i++) { + Q_re = Q->me[i]; + for (j = i; j < j_end; j++) { // update upper diagonal part + Q_re[j] -= Qs_ve[i] * sQ_ve[j] / sQs; + Q_re[j] += v_ve[i] * v_ve[j] / sv; + if (_eigen_control) + Q->me[j][i] = Q_re[j]; // update lower diagonal part + } + } + + if (_eigen_control) { + theta = _eps * _eps; + if (sQs < theta && sQs >= 0.0) + theta = sQs; + _sQ = symmeig(Q, MNULL, _sQ); + sQs = v_min(_sQ, NULL); + sQs -= theta; + if (sQs < 0.0) { + for (i = 0; i < i_end; i++) + Q->me[i][i] -= sQs; + if (_logging) { + fprintf(stderr, "Eigenvalues: %g ... %g --> ", + v_min(_sQ, NULL), v_max(_sQ, NULL)); + _sQ = symmeig(Q, MNULL, _sQ); + fprintf(stderr, "%g ... %g\n", + v_min(_sQ, NULL), v_max(_sQ, NULL)); + } + } + } +} + +//-------------------------------------------------------------------------- +void Hqp_HL_BFGS::update(const VEC *s, const VEC *u, Real alpha, + Hqp_SqpProgram *prg) +{ + SPMAT *Q = prg->qp()->Q; + VEC b_s, b_u; + int offs, size; + + b_u.max_dim = 0; + b_s.max_dim = 0; + b_u.dim = _b_Q->n; + b_s.dim = _b_Q->n; + + _b_begin = 0; + + while(next_block(Q, &offs, &size)) { + if (size != (int)b_u.dim) { + b_u.dim = size; + b_s.dim = size; + _b_Q = m_resize(_b_Q, size, size); + } + symsp_extract_mat(Q, offs, _b_Q); // build lower and upper diagonal parts + b_u.ve = u->ve + offs; + b_s.ve = s->ve + offs; + update_b_Q(&b_s, &b_u, alpha, _b_Q); + symsp_insert_symmat(Q, offs, _b_Q); // insert upper diagonal part + } +} + +//-------------------------------------------------------------------------- +// next_block: +// find next diagonal block in Q, starting with index _b_begin +//-------------------------------------------------------------------------- +int Hqp_HL_BFGS::next_block(const SPMAT *Q, int *offs, int *size) +{ + int b_end, max_col; + SPROW *row; + + if (_b_begin >= Q->m) + return 0; + + *offs = _b_begin; + + // _bsize < 0: automatic detection of the block size + // _bsize = 0: full Hessian + // _bsize > 0: block of dimension _bsize + + if (_bsize < 0) { + b_end = _b_begin; + while (_b_begin <= b_end) { + row = &(Q->row[_b_begin]); + if (row->len > 0) + max_col = row->elt[row->len - 1].col; + else + max_col = _b_begin; + b_end = max(b_end, max_col); + _b_begin ++; + } + *size = b_end - *offs + 1; + } + else { + *size = Q->n - _b_begin; + if (_bsize > 0) + *size = min(_bsize, *size); + _b_begin += *size; + } + + return 1; +} + +//========================================================================= diff --git a/hqp/Hqp_HL_BFGS.h b/hqp/Hqp_HL_BFGS.h new file mode 100644 index 0000000..31a16f0 --- /dev/null +++ b/hqp/Hqp_HL_BFGS.h @@ -0,0 +1,63 @@ +/* + * Hqp_HL_BFGS.h -- + * - BFGS Hessian approximation with Powell's modification + * - computes a separate update for every diagonal block + * + * rf, 7/19/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_HL_BFGS_H +#define Hqp_HL_BFGS_H + +#include "Hqp_HL.h" + + +class Hqp_HL_BFGS: public Hqp_HL { + + protected: + Real _gamma; + bool _eigen_control; + int _bsize; + int _max_bsize; + + VEC *_v; + VEC *_sQ; + VEC *_Qs; + + MAT *_b_Q; + int _b_begin; + + void update_b_Q(const VEC *s, const VEC *u, Real alpha, MAT *Q); + int next_block(const SPMAT *, int *offs, int *size); + + public: + Hqp_HL_BFGS(); + ~Hqp_HL_BFGS(); + + void setup(Hqp_SqpProgram *); + void update(const VEC *s, const VEC *u, Real alpha, Hqp_SqpProgram *); + + char *name() {return "BFGS";} +}; + + +#endif diff --git a/hqp/Hqp_HL_DScale.C b/hqp/Hqp_HL_DScale.C new file mode 100644 index 0000000..173da14 --- /dev/null +++ b/hqp/Hqp_HL_DScale.C @@ -0,0 +1,178 @@ +/* + * Hqp_HL_DScale.C -- + * - class definition + * + * rf, 10/26/95 + * + * rf, 2/13/97 + * - consider an initial Hessian already given in init() + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#include "Hqp_HL_DScale.h" +#include "Hqp_Program.h" +#include "Hqp_SqpProgram.h" + +IF_CLASS_DEFINE("DScale", Hqp_HL_DScale, Hqp_HL); + +//-------------------------------------------------------------------------- +Hqp_HL_DScale::Hqp_HL_DScale() +{ + _b_q = VNULL; + _sq = VNULL; + _v = VNULL; + _bsize = 0; + _gamma = 0.2; + + _ifList.append(new If_Int("sqp_hela_bsize", &_bsize)); + _ifList.append(new If_Float("sqp_hela_gamma", &_gamma)); +} + +//-------------------------------------------------------------------------- +Hqp_HL_DScale::~Hqp_HL_DScale() +{ + v_free(_b_q); + v_free(_sq); + v_free(_v); +} + +//-------------------------------------------------------------------------- +void Hqp_HL_DScale::setup(Hqp_SqpProgram *prg) +{ + SPMAT *Q = prg->qp()->Q; + SPROW *row; + int i, dim = Q->m; + row_elt *elt; + int j_idx, len; + + // clear out all off-diagonal entries + for (i = 0; i < dim; i++) { + row = Q->row + i; + elt = row->elt; + len = row->len; + for (j_idx = 0; j_idx < len; j_idx++) { + if (elt->col != i) + elt->val = 0.0; + else + elt->val = max(elt->val, _eps); + elt++; + } + } + sp_compact(Q, 0.0); + + // ensure all diagonal entries + for (i = 0; i < dim; i++) { + if (sprow_idx(Q->row + i, i) < 0) + sp_set_val(Q, i, i, _eps); + } +} + +//-------------------------------------------------------------------------- +void Hqp_HL_DScale::update_b_Q(const VEC *s, const VEC *u, VEC *q) +{ + Real sv, sqs; + Real theta; + Real *v_ve, *sq_ve, *q_ve; + int i, i_end; + + sv = in_prod(s, u); + + /* + // special treatment if sv == 0.0 + if (sv == 0.0) { + //v_set(q, _eps); + return; + } + */ + + _sq = v_star(s, q, _sq); + sqs = in_prod(_sq, s); + + // Powells correcture + if (sv < _gamma * sqs) { + theta = (1.0 - _gamma) * sqs / (sqs - sv); + _v = sv_mlt(theta, u, _v); + v_mltadd(_v, _sq, 1.0 - theta, _v); + sv = in_prod(s, _v); + } + else { + _v = v_copy(u, _v); + } + + if (!(sv != 0.0) || !(sqs != 0.0)) + return; + + v_ve = _v->ve; + sq_ve = _sq->ve; + q_ve = q->ve; + i_end = q->dim; + for (i=0; iqp()->Q; + SPROW *row; + int i, m; + VEC b_s, b_u; + int offs, size, bsize; + + m = Q->m; + offs = 0; + bsize = _bsize > 0? _bsize: m; + + b_u.max_dim = 0; + b_s.max_dim = 0; + + if (!Q->flag_diag) + sp_diag_access(Q); + + while(offs < m) { + size = min(bsize, m - offs); + _b_q = v_resize(_b_q, size); + b_s.dim = size; + b_u.dim = size; + + row = Q->row + offs; + for (i=0; ive[i] = row->elt[row->diag].val; + b_u.ve = u->ve + offs; + b_s.ve = s->ve + offs; + + update_b_Q(&b_s, &b_u, _b_q); + + row = Q->row + offs; + for (i=0; ielt[row->diag].val = _b_q->ve[i]; + + offs += size; + } +} + +//========================================================================= diff --git a/hqp/Hqp_HL_DScale.h b/hqp/Hqp_HL_DScale.h new file mode 100644 index 0000000..56ee3e7 --- /dev/null +++ b/hqp/Hqp_HL_DScale.h @@ -0,0 +1,56 @@ +/* + * Hqp_HL_DScale.h -- + * - Hessian for diagonal matrix + * + * rf, 10/26/95 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_HL_DScale_H +#define Hqp_HL_DScale_H + +#include "Hqp_HL.h" + + +class Hqp_HL_DScale: public Hqp_HL { + + protected: + Real _gamma; + + VEC *_b_q; + VEC *_sq; + VEC *_v; + int _bsize; + + void update_b_Q(const VEC *s, const VEC *u, VEC *q); + + public: + Hqp_HL_DScale(); + ~Hqp_HL_DScale(); + + void setup(Hqp_SqpProgram *); + void update(const VEC *s, const VEC *u, Real alpha, Hqp_SqpProgram *); + + char *name() {return "DScale";} +}; + + +#endif diff --git a/hqp/Hqp_HL_Gangster.C b/hqp/Hqp_HL_Gangster.C new file mode 100644 index 0000000..b9e5baa --- /dev/null +++ b/hqp/Hqp_HL_Gangster.C @@ -0,0 +1,99 @@ +/* + * Hqp_HL_Gangster.C -- + * - class definition + * + * rf, 7/19/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include + +#include "Hqp_HL_Gangster.h" +#include "Hqp_Program.h" +#include "Hqp_SqpProgram.h" + +IF_CLASS_DEFINE("Gangster", Hqp_HL_Gangster, Hqp_HL); + +//-------------------------------------------------------------------------- +Hqp_HL_Gangster::Hqp_HL_Gangster() +{ + _v = VNULL; + _sQ = VNULL; + _Qs = VNULL; + + _gamma = 0.2; + + _ifList.append(new If_Float("sqp_hela_gamma", &_gamma)); +} + +//-------------------------------------------------------------------------- +Hqp_HL_Gangster::~Hqp_HL_Gangster() +{ + v_free(_v); + v_free(_sQ); + v_free(_Qs); +} + +//-------------------------------------------------------------------------- +void Hqp_HL_Gangster::update_Q(const VEC *s, const VEC *u, Hqp_SqpProgram *prg) +{ + SPMAT *Q = prg->qp()->Q; + Real sQs, sv; + Real *v_ve, *Qs_ve, *sQ_ve; + Real theta; + int i, j, j_idx, len, m; + SPROW *row; + row_elt *elt; + + sv = in_prod(s, u); + + _Qs = sp_mv_mlt(Q, s, _Qs); + _sQ = sp_vm_mlt(Q, s, _sQ); + sQs = in_prod(_sQ, s); + + // Powells correcture + if (sv < _gamma * sQs) { + theta = (1.0 - _gamma) * sQs / (sQs - sv); + _v = sv_mlt(theta, u, _v); + v_mltadd(_v, _Qs, 1.0 - theta, _v); + sv = in_prod(s, _v); + } else { + _v = v_copy(u, _v); + } + + // Hesse matrix update with Gangster operator + v_ve = _v->ve; + sQ_ve = _sQ->ve; + Qs_ve = _Qs->ve; + m = Q->m; + row = Q->row; + for (i=0; ielt; + len = row->len; + for (j_idx=0; j_idxcol; + elt->val -= Qs_ve[i] * sQ_ve[j] / sQs; + elt->val += v_ve[i] * v_ve[j] / sv; + } + } +} + +//========================================================================= diff --git a/hqp/Hqp_HL_Gangster.h b/hqp/Hqp_HL_Gangster.h new file mode 100644 index 0000000..1c11d8a --- /dev/null +++ b/hqp/Hqp_HL_Gangster.h @@ -0,0 +1,54 @@ +/* + * Hqp_HL_Gangster.h -- + * - Hessian approximation according Broyden, Fletsher, Goldfarb, Shanno + * - modification for positive definiteness according Powell + * - uses Gangster operator to avoid fill-in + * + * rf, 7/19/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_HL_Gangster_H +#define Hqp_HL_Gangster_H + +#include "Hqp_HL.h" + + +class Hqp_HL_Gangster: public Hqp_HL { + + protected: + Real _gamma; + + VEC *_v; + VEC *_sQ; + VEC *_Qs; + + public: + Hqp_HL_Gangster(); + ~Hqp_HL_Gangster(); + + void update_Q(const VEC *s, const VEC *u, Hqp_SqpProgram *); + + char *name() {return "Gangster";} +}; + + +#endif diff --git a/hqp/Hqp_HL_Gerschgorin.C b/hqp/Hqp_HL_Gerschgorin.C new file mode 100644 index 0000000..8b76cd3 --- /dev/null +++ b/hqp/Hqp_HL_Gerschgorin.C @@ -0,0 +1,129 @@ +/* + * Hqp_HL_Gerschgorin.C -- + * - class definition + * + * rf, 10/3/95 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include + +#include "Hqp_HL_Gerschgorin.h" +#include "Hqp_Program.h" +#include "Hqp_SqpProgram.h" + +IF_CLASS_DEFINE("Gerschgorin", Hqp_HL_Gerschgorin, Hqp_HL); + +//-------------------------------------------------------------------------- +Hqp_HL_Gerschgorin::Hqp_HL_Gerschgorin() +{ + _rowsum = VNULL; +} + +//-------------------------------------------------------------------------- +Hqp_HL_Gerschgorin::~Hqp_HL_Gerschgorin() +{ + v_free(_rowsum); +} + +//-------------------------------------------------------------------------- +void Hqp_HL_Gerschgorin::setup(Hqp_SqpProgram *prg) +{ + SPMAT *Q = prg->qp()->Q; + int i, dim = Q->m; + + _rowsum = v_resize(_rowsum, dim); + + // ensure all diagonal entries + + for (i = 0; i < dim; i++) { + if (sprow_idx(Q->row + i, i) < 0) + sp_set_val(Q, i, i, 0.0); + } + + update(VNULL, VNULL, 0.0, prg); +} + +//-------------------------------------------------------------------------- +void Hqp_HL_Gerschgorin::update(const VEC *, const VEC *, Real, + Hqp_SqpProgram *prg) +{ + SPMAT *Q; + SPROW *row; + row_elt *elt; + Real *rs_ve, val; + int i, i_end; + int j, j_idx, j_end; + + // enshure positive definiteness + Q = prg->qp()->Q; + + if (!Q->flag_diag) + sp_diag_access(Q); + + v_zero(_rowsum); + row = Q->row; + rs_ve = _rowsum->ve; + i_end = Q->m; + for (i = 0; i < i_end; i++, row++) { + j_end = row->len; + j_idx = row->diag + 1; + if (j_idx <= 0) { + // there must always be a diagonal entry + error(E_INTERN, "Hqp_HL_Gerschgorin::update_Q"); + } + elt = row->elt + j_idx; + for (; j_idx < j_end; j_idx++, elt++) { + j = elt->col; + val = fabs(elt->val); + rs_ve[i] += val; + rs_ve[j] += val; + } + } + + row = Q->row; + for (i = 0; i < i_end; i++, row++, rs_ve++) { + elt = row->elt + row->diag; + elt->val = max(elt->val, *rs_ve + _eps); + } + +/* + // enshure positive definitness + Q = prg->qp()->Q; + i_end = Q->m; + for (i=0; irow[i].len; + elt = Q->row[i].elt; + diag_elt = NULL; + for (j_idx=0; j_idxcol != i) + rowsum += fabs(elt->val); + else + diag_elt = elt; + } + assert(diag_elt); + diag_elt->val = max(diag_elt->val, rowsum + _eps); + } +*/ +} + +//========================================================================= diff --git a/hqp/Hqp_HL_Gerschgorin.h b/hqp/Hqp_HL_Gerschgorin.h new file mode 100644 index 0000000..2516475 --- /dev/null +++ b/hqp/Hqp_HL_Gerschgorin.h @@ -0,0 +1,50 @@ +/* + * Hqp_HL_Gerschgorin.h -- + * - program supplied Hessian that is modified for positive definitness + * according Gerschgorin's lemma + * + * rf, 10/3/95 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_HL_Gerschgorin_H +#define Hqp_HL_Gerschgorin_H + +#include "Hqp_HL.h" + + +class Hqp_HL_Gerschgorin: public Hqp_HL { + + VEC *_ones; + VEC *_rowsum; + + public: + Hqp_HL_Gerschgorin(); + ~Hqp_HL_Gerschgorin(); + + void setup(Hqp_SqpProgram *); + void update(const VEC *s, const VEC *u, Real alpha, Hqp_SqpProgram *); + + char *name() {return "Gerschgorin";} +}; + + +#endif diff --git a/hqp/Hqp_HL_SparseBFGS.C b/hqp/Hqp_HL_SparseBFGS.C new file mode 100644 index 0000000..c20cf19 --- /dev/null +++ b/hqp/Hqp_HL_SparseBFGS.C @@ -0,0 +1,283 @@ +/* + * Hqp_HL_SparseBFGS.C -- + * - class definition + * + * rf, 7/19/95 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#include "Hqp_HL_SparseBFGS.h" +#include "Hqp_Program.h" +#include "Hqp_SqpProgram.h" + +#include "sprcm.h" + +IF_CLASS_DEFINE("SparseBFGS", Hqp_HL_SparseBFGS, Hqp_HL); + +//-------------------------------------------------------------------------- +Hqp_HL_SparseBFGS::Hqp_HL_SparseBFGS() +{ + _gamma = 0.2; + + _Q2B = PNULL; + _B2Q = PNULL; + _v = VNULL; + _sQ = VNULL; + _Qs = VNULL; + _b_Q = m_get(1, 1); + _b_u = v_get(1); + _b_s = v_get(1); + + _ifList.append(new If_Float("sqp_hela_gamma", &_gamma)); +} + +//-------------------------------------------------------------------------- +Hqp_HL_SparseBFGS::~Hqp_HL_SparseBFGS() +{ + px_free(_Q2B); + px_free(_B2Q); + v_free(_v); + v_free(_sQ); + v_free(_Qs); + m_free(_b_Q); + v_free(_b_u); + v_free(_b_s); +} + +//-------------------------------------------------------------------------- +void Hqp_HL_SparseBFGS::setup(Hqp_SqpProgram *prg) +{ + int i, idx, offs, size; + SPMAT *Q = prg->qp()->Q; + row_elt *elt; + MAT *b_Q_ones; + + // find block diagonal structure + + _Q2B = sp_symrcm(Q, _Q2B); + _B2Q = px_inv(_Q2B, _B2Q); + + // copy the upper diagonal part to the lower diagonal + + for (i = Q->m - 1; i >= 0; i--) { + elt = Q->row[i].elt; + size = Q->row[i].len; + for (idx = 0; idx < size; idx++, elt++) { + if (elt->col > i) + sp_set_val(Q, elt->col, i, elt->val); + } + } + + // fill up the blocks + + pxinv_sprows(_Q2B, Q, Q); + pxinv_spcols(_Q2B, Q, Q); + _b_begin = 0; + b_Q_ones = m_get(_b_Q->m, _b_Q->n); + m_ones(b_Q_ones); + while(next_block(Q, &offs, &size)) { + if (!_b_Q || size != (int)_b_Q->m) { + _b_Q = m_resize(_b_Q, size, size); + b_Q_ones = m_resize(b_Q_ones, size, size); + m_ones(b_Q_ones); + } + sp_extract_mat(Q, offs, offs, _b_Q); + sp_insert_mat(Q, offs, offs, b_Q_ones); // allocate entries + sp_update_mat(Q, offs, offs, _b_Q); + } + pxinv_sprows(_B2Q, Q, Q); + pxinv_spcols(_B2Q, Q, Q); + + m_free(b_Q_ones); +} + +//-------------------------------------------------------------------------- +void Hqp_HL_SparseBFGS::update_b_Q(const VEC *s, const VEC *u, Real, MAT *Q) +{ + Real sv, sQs; + Real theta; + Real *v_ve, *Qs_ve, *sQ_ve, *Q_re; + int i, i_end; + int j, j_end; + + sv = in_prod(s, u); + + /* + // return if s or u are zero + if (sv == 0.0) { + m_ident(Q); + sm_mlt(_eps, Q, Q); + return; + } + */ + + _sQ = vm_mlt(Q, s, _sQ); + _Qs = mv_mlt(Q, s, _Qs); + sQs = in_prod(_sQ, s); + + /* + if (!(sQs > 0.0)) { + m_ident(Q); + sm_mlt(_eps, Q, Q); + _sQ = vm_mlt(Q, s, _sQ); + _Qs = mv_mlt(Q, s, _Qs); + sQs = in_prod(_sQ, s); + } + */ + + // Powells correcture + if (sv < _gamma * sQs) { + theta = (1.0 - _gamma) * sQs / (sQs - sv); + if (!(theta <= 1.0)) { + fprintf(stderr, "bingo %g\n", theta); + theta = 1.0; + } + if (!(theta >= 0.0)) { + fprintf(stderr, "bingo %g, %g, %g\n", theta, sQs, sv); + theta = 0.0; + } + _v = sv_mlt(theta, u, _v); + v_mltadd(_v, _Qs, 1.0 - theta, _v); + sv = in_prod(s, _v); + } + else { + _v = v_copy(u, _v); + } + + if (!(sv != 0.0)) + return; + + v_ve = _v->ve; + sQ_ve = _sQ->ve; + Qs_ve = _Qs->ve; + i_end = Q->m; + j_end = Q->n; + for (i = 0; i < i_end; i++) { + Q_re = Q->me[i]; + for (j = 0; j < j_end; j++) { + Q_re[j] -= Qs_ve[i] * sQ_ve[j] / sQs; + Q_re[j] += v_ve[i] * v_ve[j] / sv; + } + } + + /* + // positive definiteness against s + _sQ = vm_mlt(Q, s, _sQ); + sQs = in_prod(_sQ, s); + if (!(sQs > 0.0)) { + m_ident(Q); + sm_mlt(_eps, Q, Q); + return; + } + + // positive definiteness against s + _sQ = vm_mlt(Q, u, _sQ); + sQs = in_prod(_sQ, u); + if (!(sQs > 0.0)) { + m_ident(Q); + sm_mlt(_eps, Q, Q); + return; + } + */ + + /* + // bounded + sQs = m_norm_inf(Q); + if (!(sQs >= _eps) || !(_eps*sQs < 1.0)) { + m_ident(Q); + sm_mlt(_eps, Q, Q); + return; + } + */ +} + +//-------------------------------------------------------------------------- +void Hqp_HL_SparseBFGS::update(const VEC *s, const VEC *u, Real alpha, + Hqp_SqpProgram *prg) +{ + SPMAT *Q = prg->qp()->Q; + int i, offs, size; + + pxinv_sprows(_Q2B, Q, Q); + pxinv_spcols(_Q2B, Q, Q); + + _b_begin = 0; + + while(next_block(Q, &offs, &size)) { + _b_Q = m_resize(_b_Q, size, size); + _b_u = v_resize(_b_u, size); + _b_s = v_resize(_b_s, size); + sp_extract_mat(Q, offs, offs, _b_Q); + for (i = 0; i < size; i++) { + _b_u->ve[i] = u->ve[_B2Q->pe[offs + i]]; + _b_s->ve[i] = s->ve[_B2Q->pe[offs + i]]; + } + update_b_Q(_b_s, _b_u, alpha, _b_Q); + sp_insert_mat(Q, offs, offs, _b_Q); + } + + pxinv_sprows(_B2Q, Q, Q); + pxinv_spcols(_B2Q, Q, Q); + +/* + FILE *fp; + fp = fopen("hess.dat", "w"); +// sp_ones(Q); + sp_foutput(fp, Q); + fclose(fp); + exit(0); +*/ +} + +//-------------------------------------------------------------------------- +// next_block: +// find next diagonal block in Q, starting with index _b_begin +//-------------------------------------------------------------------------- +int Hqp_HL_SparseBFGS::next_block(const SPMAT *Q, int *offs, int *size) +{ + int b_end, max_col; + SPROW *row; + + if (_b_begin >= Q->m) + return 0; + + *offs = _b_begin; + + b_end = _b_begin; + while (_b_begin <= b_end) { + row = &(Q->row[_b_begin]); + if (row->len > 0) + max_col = row->elt[row->len - 1].col; + else + max_col = _b_begin; + b_end = max(b_end, max_col); + _b_begin ++; + } + + *size = b_end - *offs + 1; + + return 1; +} + +//========================================================================= diff --git a/hqp/Hqp_HL_SparseBFGS.h b/hqp/Hqp_HL_SparseBFGS.h new file mode 100644 index 0000000..0ebdb2f --- /dev/null +++ b/hqp/Hqp_HL_SparseBFGS.h @@ -0,0 +1,66 @@ +/* + * Hqp_HL_SparseBFGS.h -- + * - BFGS Hessian approximation according Powell + * - apply RCM sparsity analysis + * - computes a separate update for every diagonal block + * + * rf, 7/19/95 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_HL_SparseBFGS_H +#define Hqp_HL_SparseBFGS_H + +#include "Hqp_HL.h" + + +class Hqp_HL_SparseBFGS: public Hqp_HL { + + protected: + Real _gamma; + + PERM *_Q2B; + PERM *_B2Q; + + VEC *_v; + VEC *_sQ; + VEC *_Qs; + + MAT *_b_Q; + VEC *_b_u; + VEC *_b_s; + int _b_begin; + + void update_b_Q(const VEC *s, const VEC *u, Real alpha, MAT *Q); + int next_block(const SPMAT *, int *offs, int *size); + + public: + Hqp_HL_SparseBFGS(); + ~Hqp_HL_SparseBFGS(); + + void setup(Hqp_SqpProgram *); + void update(const VEC *s, const VEC *u, Real alpha, Hqp_SqpProgram *); + + char *name() {return "SparseBFGS";} +}; + + +#endif diff --git a/hqp/Hqp_Init.C b/hqp/Hqp_Init.C new file mode 100644 index 0000000..a23d4ac --- /dev/null +++ b/hqp/Hqp_Init.C @@ -0,0 +1,245 @@ +/* + * central command for setting up several tasks + * + * rf, 6/21/94 + * + * rf, 4/13/99 + * rename hqp.tcl to hqp_solve.tcl for initial evaluation + * + * rf, 12/25/99 + * add support for Tcl package handling + * + * rf, 00/11/01 + * add support for MSC + * + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#include +#include +#include +#include +#include + +#include "Hqp.h" +#include "Hqp_SqpSolver.h" +#include "Hqp_SqpProgram.h" + +#include "Hqp_SqpPowell.h" + +/** static list of general Hqp interface elements */ +static If_List _ifList; + +/** Hold a pointer to the Hqp_SqpProgram */ +Hqp_SqpProgram *theSqpProgram; + +/** Hold a pointer to the Hqp_SqpSolver */ +Hqp_SqpSolver *theSqpSolver; + +#ifdef IF_CLASS_STATIC +//-------------------------------------------------------------------------- +// Ensure linkage of modules +// where automatic inclusion of all objects does not work. +//-------------------------------------------------------------------------- +#if defined(HQP_WITH_ASCEND) +#include "Prg_ASCEND.h" +#endif +#if defined(HQP_WITH_CUTE) +#include "Prg_CUTE.h" +#include "Prg_CUTE_ST.h" +#endif +#include "Hqp_SqpSchittkowski.h" +#include "Hqp_HL_BFGS.h" +#include "Hqp_HL_DScale.h" +#include "Hqp_HL_Gerschgorin.h" +#include "Hqp_IpRedSpBKP.h" +#include "Hqp_IpSpBKP.h" +#include "Hqp_IpLQDOCP.h" +#include "Hqp_IpSpSC.h" +#include "Hqp_IpsFranke.h" +#include "Hqp_IpsMehrotra.h" +#include "Hqp_Client.h" + +static void Hqp_ClassAlloc() +{ + IF_CLASS_ALLOC("Client", Hqp_Client, Hqp_Solver); + IF_CLASS_ALLOC("Mehrotra", Hqp_IpsMehrotra, Hqp_Solver); + IF_CLASS_ALLOC("Franke", Hqp_IpsFranke, Hqp_Solver); + IF_CLASS_ALLOC("SpSC", Hqp_IpSpSC, Hqp_IpMatrix); + IF_CLASS_ALLOC("LQDOCP", Hqp_IpLQDOCP, Hqp_IpMatrix); + IF_CLASS_ALLOC("SpBKP", Hqp_IpSpBKP, Hqp_IpMatrix); + IF_CLASS_ALLOC("RedSpBKP", Hqp_IpRedSpBKP, Hqp_IpMatrix); + IF_CLASS_ALLOC("Gerschgorin", Hqp_HL_Gerschgorin, Hqp_HL); + IF_CLASS_ALLOC("DScale", Hqp_HL_DScale, Hqp_HL); + IF_CLASS_ALLOC("BFGS", Hqp_HL_BFGS, Hqp_HL); + IF_CLASS_ALLOC("Schittkowski", Hqp_SqpSchittkowski, Hqp_SqpSolver); + IF_CLASS_ALLOC("Powell", Hqp_SqpPowell, Hqp_SqpSolver); +#if defined(HQP_WITH_CUTE) + IF_CLASS_ALLOC("CUTE_ST", Prg_CUTE_ST, Hqp_SqpProgram); + IF_CLASS_ALLOC("CUTE", Prg_CUTE, Hqp_SqpProgram); +#endif +#if defined(HQP_WITH_ASCEND) + IF_CLASS_ALLOC("ASCEND", Prg_ASCEND, Hqp_SqpProgram); +#endif +} +#endif + +//-------------------------------------------------------------------------- +// return HQP's version +//-------------------------------------------------------------------------- +const char *Hqp_Version = VERSION; + +static int Hqp_VersionCmd(int, char *[], char **result) +{ + *result = (char *)Hqp_Version; + return IF_OK; +} + +//-------------------------------------------------------------------------- +// fulfill the Meschach copyright +//-------------------------------------------------------------------------- +static int m_version_cmd(int, char *[], char **) +{ + m_version(); + + return IF_OK; +} + +//-------------------------------------------------------------------------- +static void signal_handler(int code) +{ + switch (code) { + + case SIGINT: + Tcl_Eval(theInterp, "hqp_exit {signal interrupt}"); + fprintf(stderr, "HQP %s: %s\n", Hqp_Version, "signal interrupt"); + break; +#if !defined(_MSC_VER) + case SIGXCPU: + signal(SIGXCPU, SIG_IGN); + Tcl_Eval(theInterp, "hqp_exit {signal cputime}"); + fprintf(stderr, "HQP %s: %s\n", Hqp_Version, "signal cputime"); + break; +#endif + default: + break; + } + + fprintf(stderr, "%s\n", theInterp->result); + exit(0); +} + +//-------------------------------------------------------------------------- +extern "C" HQP_API int Hqp_Init(Tcl_Interp *interp) +{ + // provide Tcl package Hqp + if (Tcl_PkgRequire(interp, "Tcl", "8.0", 0) == NULL || + Tcl_PkgProvide(interp, "Hqp", (char *)Hqp_Version) != TCL_OK) { + return TCL_ERROR; + } + + // initialize global reference to Tcl interpreter + theInterp = interp; + + // disable Meschach's error counting + // (otherwise program would exit if counter reaches 100) + count_errs(0); + +#if 0 + // don't use error handling as this doesn't seem to work + // for Hqp a shared lib and loaded to an executable + // rf, 2/7/97 + int code; + char *reason; + + if ((code = setjmp(restart)) != 0) { + + set_err_flag(EF_EXIT); // avoid recursive error calls + + switch (code) { + case E_MEM: + reason = "out of memory"; + break; + case E_SING: + reason = "singular matrix"; + break; + default: + reason = "execution error"; + } + + Tcl_VarEval(theInterp, "hqp_exit {", reason, "}", NULL); + fprintf(stderr, "HQP %s: %s\n", Hqp_Version, reason); + fprintf(stderr, "%s\n", theInterp->result); + exit(-1); + } + set_err_flag(EF_JUMP); +#endif + + // allocate interface modules +# ifdef IF_CLASS_STATIC + Hqp_ClassAlloc(); +# endif + + // create initial state + theSqpProgram = NULL; + theSqpSolver = new Hqp_SqpPowell; + +#ifdef HQP_GENDLL + // allocate interface elements dynamically + // as destoying them upon DLL detach does not work + // (NT 4 application crashes with bad memory access on exit) + If_List *ifList_ptr = new If_List(); + If_List &_ifList = *ifList_ptr; +#endif + _ifList.append(new IF_MODULE("sqp_solver", &theSqpSolver, Hqp_SqpSolver)); + _ifList.append(new IF_MODULE("prg_name", &theSqpProgram, Hqp_SqpProgram)); + _ifList.append(new If_Proc("hqp_version", &Hqp_VersionCmd)); + _ifList.append(new If_Proc("m_version", &m_version_cmd)); + + // install a handler for signal interrupt + signal(SIGINT, &signal_handler); +#if !defined(_MSC_VER) + signal(SIGXCPU, &signal_handler); +#endif + + // ignore signals from floating point arithmetics + // (needed for ADOL-C 1.7 on Alpha with OSF3.2, OSF4.0) + signal(SIGFPE, SIG_IGN); + + // evaluate hqp_solve.tcl + extern char *hqp_solve; + if (Tcl_Eval(interp, hqp_solve) == TCL_ERROR) { + fprintf(stderr, + "Evaluation of built-in code failed: %s\n", interp->result); + } + + // evaluate file ~/.hqprc if it exists + if (Tcl_Eval(interp, "if {[file exists ~/.hqprc]} {source ~/.hqprc}") + != TCL_OK) { + fprintf(stderr, + "Evaluation of ~/.hqprc failed: %s\n", interp->result); + } + + return TCL_OK; +} diff --git a/hqp/Hqp_IpBdBKP.C b/hqp/Hqp_IpBdBKP.C new file mode 100644 index 0000000..84fe101 --- /dev/null +++ b/hqp/Hqp_IpBdBKP.C @@ -0,0 +1,238 @@ +/* + * Hqp_IpBdBKP.C -- class definition + * + * rf, 9/9/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +extern "C" { +#include +#include +} +#include "sprcm.h" + +#include + +#include "Hqp_Program.h" +#include "Hqp_IpBdBKP.h" + +IF_CLASS_DEFINE("BdBKP", Hqp_IpBdBKP, Hqp_IpMatrix); + +//-------------------------------------------------------------------------- +Hqp_IpBdBKP::Hqp_IpBdBKP() +{ + _n = _me = _m = 0; + _sbw = -1; + _J = BDNULL; + _J_raw = BDNULL; + _J_fct = BDNULL; + _QP2J = PNULL; + _J2QP = PNULL; + _pivot = PNULL; + _blocks = PNULL; + _scale = VNULL; + _r123 = VNULL; + _xyz = VNULL; + _test = VNULL; + _z = VNULL; + _C = SMNULL; + + _ifList.append(new If_Int("mat_sbw", &_sbw)); +} + +//-------------------------------------------------------------------------- +Hqp_IpBdBKP::~Hqp_IpBdBKP() +{ + bd_free(_J); + bd_free(_J_raw); + bd_free(_J_fct); + px_free(_QP2J); + px_free(_J2QP); + px_free(_pivot); + px_free(_blocks); + v_free(_scale); + v_free(_r123); + v_free(_xyz); + v_free(_z); + v_free(_test); +} + +//-------------------------------------------------------------------------- +void Hqp_IpBdBKP::init(const Hqp_Program *qp) +{ + int dim; + IVEC *degree, *neigh_start, *neighs; + + _n = qp->c->dim; + _me = qp->b->dim; + _m = qp->d->dim; + dim = _n + _me + _m; + + _C = qp->C; + + // determine RCM ordering + + degree = iv_get(dim); + neigh_start = iv_get(dim + 1); + neighs = sp_rcm_scan(qp->Q, qp->A, qp->C, degree, neigh_start, IVNULL); + + _QP2J = sp_rcm_order(degree, neigh_start, neighs, _QP2J); + _sbw = sp_rcm_sbw(neigh_start, neighs, _QP2J); + _J2QP = px_inv(_QP2J, _J2QP); + + iv_free(degree); + iv_free(neigh_start); + iv_free(neighs); + + // allocate memory + + _J = bd_resize(_J, _sbw, _sbw, dim); + _J_raw = bd_resize(_J_raw, _sbw, _sbw, dim); + _J_fct = bd_resize(_J_fct, _sbw, 2 * _sbw, dim); + _pivot = px_resize(_pivot, dim); + _blocks = px_resize(_blocks, dim); + _scale = v_resize(_scale, _m); + _r123 = v_resize(_r123, dim); + _xyz = v_resize(_xyz, dim); + _test = v_resize(_test, dim); + + // fill up data + + update(qp); +} + +//-------------------------------------------------------------------------- +void Hqp_IpBdBKP::update(const Hqp_Program *qp) +{ + m_zero(_J_raw->mat); + sp_into_bd(qp->Q, -1.0, _J_raw, _QP2J, 0, 0); + spT_into_bd(qp->A, 1.0, _J_raw, _QP2J, 0, _n); + spT_into_bd(qp->C, 1.0, _J_raw, _QP2J, 0, _n+_me); + sp_into_bd(qp->A, 1.0, _J_raw, _QP2J, _n, 0); + sp_into_bd(qp->C, 1.0, _J_raw, _QP2J, _n+_me, 0); + + _C = qp->C; +} + +//-------------------------------------------------------------------------- +void Hqp_IpBdBKP::factor(const VEC *z, const VEC *w) +{ + assert((int)z->dim == _m && (int)w->dim == _m); + + int i, i_end; + int j, j_end, k, l; + int lb, ub, bw; + Real wz; + Real **Jmat; + int dim = _n+_me+_m; + + // store z for following solve + _z = v_copy(z, _z); + + // copy _J_raw into _J + + bd_copy(_J_raw, _J); + + // insert slacks, diagonal scaling + + lb = _J->lb; + ub = _J->ub; + bw = _J->mat->m; + Jmat = _J->mat->me; + j_end = _m; + for (j=0; jve[j] / z->ve[j]; + k = _QP2J->pe[j+dim-_m]; + Jmat[lb][k] = wz; // insert diagonal entry + wz = min(1.0, sqrt(1.0 / wz)); + _scale->ve[j] = wz; + i_end = _J_raw->mat->m; + for (i=0; ilb, _J->ub, dim); // no memory reallocation! + bd_copy(_J, _J_fct); + + // factorization of _J_fct + + bdBKPfactor(_J_fct, _pivot, _blocks); +} + +//-------------------------------------------------------------------------- +Real Hqp_IpBdBKP::solve(const VEC *r1, const VEC *r2, const VEC *r3, + const VEC *r4, VEC *dx, VEC *dy, VEC *dz, VEC *dw) +{ + VEC v; + Real residuum; + + assert((int)r1->dim == _n && (int)dx->dim == _n); + assert((int)r2->dim == _me && (int)dy->dim == _me); + assert((int)r3->dim == _m && (int)dz->dim == _m); + assert((int)r4->dim == _m && (int)dw->dim == _m); + + // copy, scale and permutate [r1;r2;r3] into _r123 + // calculate, permutate and scale x + + v_copy(r1, v_part(_r123, 0, _n, &v)); + v_copy(r2, v_part(_r123, _n, _me, &v)); + v_part(_r123, _n+_me, _m, &v); + v_slash(_z, r4, &v); + v_add(&v, r3, &v); + v_star(&v, _scale, &v); + + px_vec(_J2QP, _r123, _r123); + + bdBKPsolve(_J_fct, _pivot, _blocks, _r123, _xyz); + + bd_mv_mlt(_J, _xyz, _test); + v_sub(_r123, _test, _test); + residuum = v_norm2(_test); + + px_vec(_QP2J, _xyz, _xyz); + + v_copy(v_part(_xyz, 0, _n, &v), dx); + v_copy(v_part(_xyz, _n, _me, &v), dy); + v_star(v_part(_xyz, _n+_me, _m, &v), _scale, dz); + + // calculate dw + + sv_mlt(-1.0, r3, dw); + sp_mv_mltadd(dw, dx, _C, 1.0, dw); + + return residuum; +} + + +//========================================================================== diff --git a/hqp/Hqp_IpBdBKP.h b/hqp/Hqp_IpBdBKP.h new file mode 100644 index 0000000..07fd10b --- /dev/null +++ b/hqp/Hqp_IpBdBKP.h @@ -0,0 +1,67 @@ +/* + * Hqp_IpBdBKP.h -- + * - manage the Jacobian matrix of Interior Point algorithms + * - use band matrix and BKP factorization + * + * rf, 9/9/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_IpBdBKP_H +#define Hqp_IpBdBKP_H + +#include "Hqp_IpMatrix.h" + + +class Hqp_IpBdBKP: public Hqp_IpMatrix { + + protected: + int _n, _me, _m; // dimensions + int _sbw; // semi band width of _J + BAND *_J; + BAND *_J_raw; + BAND *_J_fct; + PERM *_QP2J; + PERM *_J2QP; + PERM *_pivot; + PERM *_blocks; + VEC *_scale; + VEC *_r123; + VEC *_xyz; + VEC *_test; + VEC *_z; + SPMAT *_C; + + public: + Hqp_IpBdBKP(); + ~Hqp_IpBdBKP(); + + void init(const Hqp_Program *); + void update(const Hqp_Program *); + + void factor(const VEC *z, const VEC *w); + Real solve(const VEC *r1, const VEC *r2, const VEC *r3, const VEC *r4, + VEC *dx, VEC *dy, VEC *dz, VEC *dw); + + char *name() {return "BdBKP";} +}; + +#endif diff --git a/hqp/Hqp_IpBdLU.C b/hqp/Hqp_IpBdLU.C new file mode 100644 index 0000000..4d69271 --- /dev/null +++ b/hqp/Hqp_IpBdLU.C @@ -0,0 +1,304 @@ +/* + * Hqp_IpBdLU.C -- class definition + * + * rf, 9/7/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +extern "C" { +#include +} + +#include "Hqp_Program.h" +#include "Hqp_Structure.h" +#include "Hqp_IpBdLU.h" + + +//-------------------------------------------------------------------------- +Hqp_IpBdLU::Hqp_IpBdLU() +{ + _n = _me = _m = 0; + _CT = SMNULL; + _J = BDNULL; + _J_raw = BDNULL; + _J_fct = BDNULL; + _QP2J = PNULL; + _J2QP = PNULL; + _pivot = PNULL; + _zw = VNULL; + _scale = VNULL; + _r12 = VNULL; + _xy = VNULL; + _test = VNULL; + _CTC_structure = new Hqp_Structure; +} + +//-------------------------------------------------------------------------- +Hqp_IpBdLU::~Hqp_IpBdLU() +{ + sp_free(_CT); + bd_free(_J); + bd_free(_J_raw); + bd_free(_J_fct); + px_free(_QP2J); + px_free(_J2QP); + px_free(_pivot); + v_free(_zw); + v_free(_scale); + v_free(_r12); + v_free(_xy); + v_free(_test); + delete _CTC_structure; +} + +//-------------------------------------------------------------------------- +BAND *Hqp_IpBdLU::sub_CTC(const PERM *px, BAND *Q) +// return Q - _CT * diags(_zw) * _CT' +// read: _CT, _zw +// write: _scale +{ + int i, j, j_idx, j_end; + int qi, qj; + SPROW *crow; + Real sum, val; + const IVEC *neigh; + int lb; + Real **Qmat; + + lb = Q->lb; + Qmat = Q->mat->me; + crow = _CT->row; + for (i=0; i<_n; i++, crow++) { + + if (crow->len <= 0) { + // just init scaling + val = Qmat[lb][px->pe[i]]; + _scale->ve[i] = min(1.0, sqrt(-1.0 / val)); + } + else { + + // calculate diagonal entry + sum = sprow_inprod(crow, _zw, crow); + val = Qmat[lb][px->pe[i]] -= sum; + _scale->ve[i] = min(1.0, sqrt(-1.0 / val)); + + // calculate resting entries + neigh = _CTC_structure->neighbours(i); + j_end = neigh->dim; + for (j_idx=0; j_idxive[j_idx]; + if (j < i) { + sum = sprow_inprod(crow, _zw, _CT->row + j); + qi = px->pe[i]; + qj = px->pe[j]; + + // substract sum from Qij and Qji + + Qmat[lb+qj-qi][qj] -= sum; + Qmat[lb+qi-qj][qi] -= sum; + } + } + } + } + + return Q; +} + +//-------------------------------------------------------------------------- +void Hqp_IpBdLU::init(const Hqp_Program *qp) +{ + Hqp_Structure *sp = new Hqp_Structure; + SPMAT *QCTC; + SPROW *r1, *r2; + int i, j; + int dim; + Real sum; + const Hqp_BandSize *bds; + + _n = qp->c->dim; + _me = qp->b->dim; + _m = qp->d->dim; + dim = _n + _me; + + // reallocations + + _pivot = px_resize(_pivot, dim); + _zw = v_resize(_zw, _m); + _scale = v_resize(_scale, _n); + _r12 = v_resize(_r12, dim); + _xy = v_resize(_xy, dim); + _test = v_resize(_test, dim); + + // store C' for further computations + // analyze structure of C'*C + + _CT = sp_transp(qp->C, _CT); + sp_ones(_CT); + v_ones(_zw); + QCTC = sp_get(_n, _n, 10); + r1 = _CT->row; + for (i=0; i<_n; i++, r1++) { + r2 = r1; + for (j=i; j<_n; j++, r2++) { + sum = sprow_inprod(r1, _zw, r2); + if (sum != 0.0) { + sp_set_val(QCTC, i, j, sum); + if (i != j) + sp_set_val(QCTC, j, i, sum); + } + } + } + _CTC_structure->init_spmat(QCTC); + + // initialize structure of reduced qp + + QCTC = sp_add(qp->Q, QCTC, QCTC); + sp->init_QA(QCTC, qp->A); + sp->order_rcm(); + _QP2J = sp->px_get(_QP2J); + _J2QP = px_inv(_QP2J, _J2QP); + bds = sp->bd_size(); + _J = bd_resize(_J, bds->lb, bds->ub, dim); + _J_raw = bd_resize(_J_raw, bds->lb, bds->ub, dim); + _J_fct = bd_resize(_J_fct, bds->lb, bds->ub + bds->lb, dim); + + delete sp; + sp_free(QCTC); + + // prepare iterations + + update(qp); +} + +//-------------------------------------------------------------------------- +void Hqp_IpBdLU::update(const Hqp_Program *qp) +{ + // prepare _J_raw + m_zero(_J_raw->mat); + sp_into_bd(qp->Q, -1.0, _J_raw, _QP2J, 0, 0); + spT_into_bd(qp->A, 1.0, _J_raw, _QP2J, 0, _n); + sp_into_bd(qp->A, 1.0, _J_raw, _QP2J, _n, 0); + + // update _CT + _CT = sp_transp(qp->C, _CT); +} + +//-------------------------------------------------------------------------- +void Hqp_IpBdLU::factor(const VEC *z, const VEC *w) +{ + assert(z->dim == _m && w->dim == _m); + + int i, i_end; + int j, j_end, k, l; + int lb, ub, bw; + Real scale; + Real **Jmat; + int dim = _n+_me; + + // copy _J_raw into _J + + bd_copy(_J_raw, _J); + + // augment _J + v_slash(w, z, _zw); + sub_CTC(_QP2J, _J); + + // diagonal scaling + + lb = _J->lb; + ub = _J->ub; + bw = _J->mat->m; + Jmat = _J->mat->me; + j_end = _n; + for (j=0; jve[j]; + k = _QP2J->pe[j]; + i_end = _J_raw->mat->m; // scale k'th col of _J + for (i=0; ilb, _J->ub, dim); // no memory reallocation! + bd_copy(_J, _J_fct); + + // factorization of _J_fct + + bdLUfactor(_J_fct, _pivot); +} + +//-------------------------------------------------------------------------- +Real Hqp_IpBdLU::solve(const VEC *r1, const VEC *r2, const VEC *r3, + VEC *dx, VEC *dy, VEC *dz) +{ + static VEC v; + Real residuum; + + assert(r1->dim == _n && dx->dim == _n); + assert(r2->dim == _me && dy->dim == _me); + assert(r3->dim == _m && dz->dim == _m); + + // augment, copy, scale and permutate [r1;r2;r3] into _r12 + // calculate, permutate and scale x + + // augment r1 + v_part(_r12, 0, _n, &v); + v_star(_zw, r3, dz); + sp_mv_mlt(_CT, dz, &v); + v_sub(r1, &v, &v); + v_star(&v, _scale, &v); + + v_copy(r2, v_part(_r12, _n, _me, &v)); + + px_vec(_J2QP, _r12, _r12); + + bdLUsolve(_J_fct, _pivot, _r12, _xy); + + bd_mv_mlt(_J, _xy, _test); + v_sub(_r12, _test, _test); + residuum = v_norm2(_test); + + px_vec(_QP2J, _xy, _xy); + + v_star(v_part(_xy, 0, _n, &v), _scale, dx); + v_copy(v_part(_xy, _n, _me, &v), dy); + + sp_vm_mlt(_CT, dx, dz); + v_sub(r3, dz, dz); + v_star(_zw, dz, dz); + + return residuum; +} + + +//========================================================================== diff --git a/hqp/Hqp_IpBdLU.h b/hqp/Hqp_IpBdLU.h new file mode 100644 index 0000000..2de5d95 --- /dev/null +++ b/hqp/Hqp_IpBdLU.h @@ -0,0 +1,71 @@ +/* + * Hqp_IpBdLU.h -- + * - manage the Jacobian matrix of Interior Point algorithms + * - eliminate inequality constraints + * - use band matrix and LU factorization + * - only one solve per factorize is supported (bdLUsolve!) + * + * rf, 9/7/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_IpBdLU_H +#define Hqp_IpBdLU_H + +#include "Hqp_IpMatrix.h" + +class Hqp_Structure; + +class Hqp_IpBdLU: public Hqp_IpMatrix { + + protected: + int _n, _me, _m; // dimensions + SPMAT *_CT; + BAND *_J; + BAND *_J_raw; + BAND *_J_fct; + PERM *_QP2J; + PERM *_J2QP; + PERM *_pivot; + VEC *_zw; + VEC *_scale; + VEC *_r12; + VEC *_xy; + VEC *_test; + + Hqp_Structure *_CTC_structure; + BAND *sub_CTC(const PERM *, BAND *); + + public: + Hqp_IpBdLU(); + virtual ~Hqp_IpBdLU(); + + virtual void init(const Hqp_Program *); + virtual void update(const Hqp_Program *); + + virtual void factor(const VEC *z, const VEC *w); + virtual Real solve(const VEC *r1, const VEC *r2, const VEC *r3, + VEC *dx, VEC *dy, VEC *dz); + + char *name() {return "BdLU";} +}; + +#endif diff --git a/hqp/Hqp_IpFullBdLU.C b/hqp/Hqp_IpFullBdLU.C new file mode 100644 index 0000000..4c92355 --- /dev/null +++ b/hqp/Hqp_IpFullBdLU.C @@ -0,0 +1,202 @@ +/* + * Hqp_IpFullBdLU.C -- class definition + * + * rf, 6/1/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +extern "C" { +#include +} + +#include "Hqp_Program.h" +#include "Hqp_Structure.h" +#include "Hqp_IpFullBdLU.h" + +//-------------------------------------------------------------------------- +Hqp_IpFullBdLU::Hqp_IpFullBdLU() +{ + _n = _me = _m = 0; + _J = BDNULL; + _J_raw = BDNULL; + _J_fct = BDNULL; + _QP2J = PNULL; + _J2QP = PNULL; + _pivot = PNULL; + _scale = VNULL; + _r123 = VNULL; + _xyz = VNULL; + _test = VNULL; +} + +//-------------------------------------------------------------------------- +Hqp_IpFullBdLU::~Hqp_IpFullBdLU() +{ + bd_free(_J); + bd_free(_J_raw); + bd_free(_J_fct); + px_free(_QP2J); + px_free(_J2QP); + px_free(_pivot); + v_free(_scale); + v_free(_r123); + v_free(_xyz); + v_free(_test); +} + +//-------------------------------------------------------------------------- +void Hqp_IpFullBdLU::init(const Hqp_Program *qp) +{ + Hqp_Structure *sp = new Hqp_Structure; + const Hqp_BandSize *bds; + int dim; + + _n = qp->c->dim; + _me = qp->b->dim; + _m = qp->d->dim; + dim = _n + _me + _m; + + // allocate memory + + sp->init_QAC(qp->Q, qp->A, qp->C); + sp->order_rcm(); + _QP2J = sp->px_get(_QP2J); + _J2QP = px_inv(_QP2J, _J2QP); + bds = sp->bd_size(); + _J = bd_resize(_J, bds->lb, bds->ub, dim); + _J_raw = bd_resize(_J_raw, bds->lb, bds->ub, dim); + _J_fct = bd_resize(_J_fct, bds->lb, bds->ub + bds->lb, dim); + _pivot = px_resize(_pivot, dim); + _scale = v_resize(_scale, _m); + _r123 = v_resize(_r123, dim); + _xyz = v_resize(_xyz, dim); + _test = v_resize(_test, dim); + + delete sp; + + // fill up data + + update(qp); +} + +//-------------------------------------------------------------------------- +void Hqp_IpFullBdLU::update(const Hqp_Program *qp) +{ + m_zero(_J_raw->mat); + sp_into_bd(qp->Q, -1.0, _J_raw, _QP2J, 0, 0); + spT_into_bd(qp->A, 1.0, _J_raw, _QP2J, 0, _n); + spT_into_bd(qp->C, 1.0, _J_raw, _QP2J, 0, _n+_me); + sp_into_bd(qp->A, 1.0, _J_raw, _QP2J, _n, 0); + sp_into_bd(qp->C, 1.0, _J_raw, _QP2J, _n+_me, 0); +} + +//-------------------------------------------------------------------------- +void Hqp_IpFullBdLU::factor(const VEC *z, const VEC *w) +{ + assert(z->dim == _m && w->dim == _m); + + int i, i_end; + int j, j_end, k, l; + int lb, ub, bw; + Real wz; + Real **Jmat; + int dim = _n+_me+_m; + + // copy _J_raw into _J + + bd_copy(_J_raw, _J); + + // insert slacks, diagonal scaling + + lb = _J->lb; + ub = _J->ub; + bw = _J->mat->m; + Jmat = _J->mat->me; + j_end = _m; + for (j=0; jve[j] / z->ve[j]; + k = _QP2J->pe[j+dim-_m]; + Jmat[lb][k] = wz; // insert diagonal entry + wz = min(1.0, sqrt(1.0 / wz)); + _scale->ve[j] = wz; + i_end = _J_raw->mat->m; + for (i=0; ilb, _J->ub, dim); // no memory reallocation! + bd_copy(_J, _J_fct); + + // factorization of _J_fct + + bdLUfactor(_J_fct, _pivot); +} + +//-------------------------------------------------------------------------- +Real Hqp_IpFullBdLU::solve(const VEC *r1, const VEC *r2, const VEC *r3, + VEC *dx, VEC *dy, VEC *dz) +{ + static VEC v; + Real residuum; + + assert(r1->dim == _n && dx->dim == _n); + assert(r2->dim == _me && dy->dim == _me); + assert(r3->dim == _m && dz->dim == _m); + + // copy, scale and permutate [r1;r2;r3] into _r123 + // calculate, permutate and scale x + + v_copy(r1, v_part(_r123, 0, _n, &v)); + v_copy(r2, v_part(_r123, _n, _me, &v)); + v_star(r3, _scale, v_part(_r123, _n+_me, _m, &v)); + + px_vec(_J2QP, _r123, _r123); + + bdLUsolve(_J_fct, _pivot, _r123, _xyz); + + bd_mv_mlt(_J, _xyz, _test); + v_sub(_r123, _test, _test); + residuum = v_norm2(_test); + + px_vec(_QP2J, _xyz, _xyz); + + v_copy(v_part(_xyz, 0, _n, &v), dx); + v_copy(v_part(_xyz, _n, _me, &v), dy); + v_star(v_part(_xyz, _n+_me, _m, &v), _scale, dz); + + return residuum; +} + + +//========================================================================== diff --git a/hqp/Hqp_IpFullBdLU.h b/hqp/Hqp_IpFullBdLU.h new file mode 100644 index 0000000..c7a13f6 --- /dev/null +++ b/hqp/Hqp_IpFullBdLU.h @@ -0,0 +1,64 @@ +/* + * Hqp_IpFullBdLU.h -- + * - manage the Jacobian matrix of Interior Point algorithms + * - use band matrix and LU factorization + * - only one "solve" is supported per "factorize" (because of bdLUsolve) + * + * rf, 6/1/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_IpFullBdLU_H +#define Hqp_IpFullBdLU_H + +#include "Hqp_IpMatrix.h" + + +class Hqp_IpFullBdLU: public Hqp_IpMatrix { + + protected: + int _n, _me, _m; // dimensions + BAND *_J; + BAND *_J_raw; + BAND *_J_fct; + PERM *_QP2J; + PERM *_J2QP; + PERM *_pivot; + VEC *_scale; + VEC *_r123; + VEC *_xyz; + VEC *_test; + + public: + Hqp_IpFullBdLU(); + virtual ~Hqp_IpFullBdLU(); + + virtual void init(const Hqp_Program *); + virtual void update(const Hqp_Program *); + + virtual void factor(const VEC *z, const VEC *w); + virtual Real solve(const VEC *r1, const VEC *r2, const VEC *r3, + VEC *dx, VEC *dy, VEC *dz); + + char *name() {return "FullBdLU";} +}; + +#endif diff --git a/hqp/Hqp_IpFullSpLU.C b/hqp/Hqp_IpFullSpLU.C new file mode 100644 index 0000000..e5c207b --- /dev/null +++ b/hqp/Hqp_IpFullSpLU.C @@ -0,0 +1,220 @@ +/* + * Hqp_IpFullSpLU.C -- class definition + * + * rf, 6/2/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +extern "C" { +#include +} + +#include "Hqp_Program.h" +#include "Hqp_Structure.h" +#include "Hqp_IpFullSpLU.h" + + +//-------------------------------------------------------------------------- +Hqp_IpFullSpLU::Hqp_IpFullSpLU() +{ + _n = _me = _m = 0; + _J = SMNULL; + _J_raw = SMNULL; + _J_fct = SMNULL; + _QP2J = PNULL; + _J2QP = PNULL; + _pivot = PNULL; + _scale = VNULL; + _r123 = VNULL; + _xyz = VNULL; + _test = VNULL; +} + +//-------------------------------------------------------------------------- +Hqp_IpFullSpLU::~Hqp_IpFullSpLU() +{ + sp_free(_J); + sp_free(_J_raw); + sp_free(_J_fct); + px_free(_QP2J); + px_free(_J2QP); + px_free(_pivot); + v_free(_scale); + v_free(_r123); + v_free(_xyz); + v_free(_test); +} + +//-------------------------------------------------------------------------- +void Hqp_IpFullSpLU::init(const Hqp_Program *qp) +{ + Hqp_Structure *sp = new Hqp_Structure; + int len; + int dim; + + _n = qp->c->dim; + _me = qp->b->dim; + _m = qp->d->dim; + dim = _n + _me + _m; + + // allocate memory + + sp->init_QAC(qp->Q, qp->A, qp->C); + sp->order_rcm(); + _QP2J = sp->px_get(_QP2J); + _J2QP = px_inv(_QP2J, _J2QP); + len = 2 * sp->nentries() / dim; + sp_free(_J); + sp_free(_J_raw); + sp_free(_J_fct); + _J_raw = sp_get(dim, dim, len); + _J_fct = SMNULL; + _J = SMNULL; + _pivot = px_resize(_pivot, dim); + _scale = v_resize(_scale, _m); + _r123 = v_resize(_r123, dim); + _xyz = v_resize(_xyz, dim); + _test = v_resize(_test, dim); + + delete sp; + + // fill up data + + update(qp); +} + +//-------------------------------------------------------------------------- +void Hqp_IpFullSpLU::update(const Hqp_Program *qp) +{ + int i, i_dst; + int dim = _n+_me+_m; + + sp_zero(_J_raw); + sp_into_sp(qp->Q, -1.0, _J_raw, _QP2J, 0, 0); + spT_into_sp(qp->A, 1.0, _J_raw, _QP2J, 0, _n); + spT_into_sp(qp->C, 1.0, _J_raw, _QP2J, 0, _n+_me); + sp_into_sp(qp->A, 1.0, _J_raw, _QP2J, _n, 0); + sp_into_sp(qp->C, 1.0, _J_raw, _QP2J, _n+_me, 0); + + for (i=_n+_me; ipe[i]; + sp_set_val(_J_raw, i_dst, i_dst, 0.0); + } +} + +//-------------------------------------------------------------------------- +void Hqp_IpFullSpLU::factor(const VEC *z, const VEC *w) +{ + assert(z->dim == _m && w->dim == _m); + + int i, i_end; + int j, j_end, k, j_idx; + int dim = _n+_me+_m; + Real wz; + SPROW *row; + row_elt *elt; + + // copy _J_raw to _J + _J = sp_copy3(_J_raw, _J); + + // insert slacks, diagonal scaling + + j_end = _m; + for (j=0; jve[j] / z->ve[j]; + k = _QP2J->pe[j+dim-_m]; + sp_set_val(_J, k, k, wz); // insert diagonal entry + wz = min(1.0, sqrt(1.0 / wz)); + _scale->ve[j] = wz; + row = &(_J->row[k]); // scale k'th row of _J + elt = row->elt; + i_end = row->len; + for (i=0; ival *= wz; + } + } + + if (!_J->flag_col) + sp_col_access(_J); + for (j=0; jve[j]; + k = _QP2J->pe[j+dim-_m]; + i = _J->start_row[k]; + j_idx = _J->start_idx[k]; + while (i >= 0) { + elt = &(_J->row[i].elt[j_idx]); + elt->val *= wz; + i = elt->nxt_row; + j_idx = elt->nxt_idx; + } + } + + // delete zeros + sp_compact(_J, 0.0); + + // copy _J to _J_fct for factorization + _J_fct = sp_copy3(_J, _J_fct); + + // factorization of _J_fct +// spLUfactor2(_J_fct, _pivot); + spLUfactor(_J_fct, _pivot, 0.1); +} + +//-------------------------------------------------------------------------- +Real Hqp_IpFullSpLU::solve(const VEC *r1, const VEC *r2, const VEC *r3, + VEC *dx, VEC *dy, VEC *dz) +{ + static VEC v; + Real residuum; + + assert(r1->dim == _n && dx->dim == _n); + assert(r2->dim == _me && dy->dim == _me); + assert(r3->dim == _m && dz->dim == _m); + + // copy, scale and permutate [r1;r2;r3] into _r123 + // calculate, permutate and scale x + + v_copy(r1, v_part(_r123, 0, _n, &v)); + v_copy(r2, v_part(_r123, _n, _me, &v)); + v_star(r3, _scale, v_part(_r123, _n+_me, _m, &v)); + + px_vec(_J2QP, _r123, _r123); + + spLUsolve(_J_fct, _pivot, _r123, _xyz); + + sp_mv_mlt(_J, _xyz, _test); + v_sub(_r123, _test, _test); + residuum = v_norm2(_test); + + px_vec(_QP2J, _xyz, _xyz); + + v_copy(v_part(_xyz, 0, _n, &v), dx); + v_copy(v_part(_xyz, _n, _me, &v), dy); + v_star(v_part(_xyz, _n+_me, _m, &v), _scale, dz); + + return residuum; +} + + +//========================================================================== diff --git a/hqp/Hqp_IpFullSpLU.h b/hqp/Hqp_IpFullSpLU.h new file mode 100644 index 0000000..d51045b --- /dev/null +++ b/hqp/Hqp_IpFullSpLU.h @@ -0,0 +1,63 @@ +/* + * Hqp_IpFullSpLU.h -- + * - manage the Jacobian matrix of Interior Point algorithms + * - use sparse matrix and LU factorization + * + * rf, 6/2/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_IpFullSpLU_H +#define Hqp_IpFullSpLU_H + +#include "Hqp_IpMatrix.h" + + +class Hqp_IpFullSpLU: public Hqp_IpMatrix { + + protected: + int _n, _me, _m; // dimensions + SPMAT *_J; + SPMAT *_J_raw; + SPMAT *_J_fct; + PERM *_QP2J; + PERM *_J2QP; + PERM *_pivot; + VEC *_scale; + VEC *_r123; + VEC *_xyz; + VEC *_test; + + public: + Hqp_IpFullSpLU(); + virtual ~Hqp_IpFullSpLU(); + + virtual void init(const Hqp_Program *); + virtual void update(const Hqp_Program *); + + virtual void factor(const VEC *z, const VEC *w); + virtual Real solve(const VEC *r1, const VEC *r2, const VEC *r3, + VEC *dx, VEC *dy, VEC *dz); + + char *name() {return "FullSpLU";} +}; + +#endif diff --git a/hqp/Hqp_IpLQDOCP.C b/hqp/Hqp_IpLQDOCP.C new file mode 100644 index 0000000..2962d43 --- /dev/null +++ b/hqp/Hqp_IpLQDOCP.C @@ -0,0 +1,2177 @@ +/* + * Hqp_IpLQDOCP.C -- class definition + * + * E. Arnold 09/24/96 + * 06/30/97 copy _A_ori, _C_ori + * 07/08/97 bugs in resize(), free() + * 08/20/99 Hqp_IpLQDOCP::Get_Dim() + * + */ + +/* + Copyright (C) 1996--1999 Eckhard Arnold + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + + +#include +#include + +extern "C" { +#include +#include +} + +#include +#include +// #include + +#include "Hqp_Program.h" +#include "Hqp_IpLQDOCP.h" + + +IF_CLASS_DEFINE("LQDOCP", Hqp_IpLQDOCP, Hqp_IpMatrix); +// typedef If_Method If_Cmd; + +#undef LOG +#ifdef LOG +#define pr_(s) printf(s) +#define pr(s,x) printf(s,x) +#else +#define pr_(s) +#define pr(s,x) +#endif + +//-------------------------------------------------------------------------- +// Calculation of matrix C^T D^{-1} C using sparsity structure of +// matrix C. Only the non-zero entries of CTC are visited. +// CTC(i,j) = CT(i,:)*(yny(:).*CT(:,j) +// E. Arnold 10/07/96 +// 06/30/97 avoid diag access +//-------------------------------------------------------------------------- +SPMAT *CTDC(const SPMAT *CT, const VEC *yny, SPMAT *CTC) +{ + int i; + int j; + SPROW *r; + row_elt *elt; + Real sum; + + if ( ( CT == SMNULL ) || ( yny == VNULL) || ( CTC == SMNULL ) ) + error(E_NULL, "CTDC"); + if ( ( CT->n != (int) yny->dim ) || ( CT->m != CTC->m ) || + ( CTC->m != CTC->n ) ) + error(E_SIZES, "CTDC"); + // if ( !CTC->flag_diag ) + // sp_diag_access(CTC); + + r = CTC->row; + for ( i = 0; i < CTC->m; i++, r++ ) { + if ( r->len > 0 ) { + // elt = r->elt+r->diag; + elt = r->elt; + // for ( j = r->diag; j < r->len; j++, elt++ ) { + for ( j = 0; j < r->len; j++, elt++ ) { + if (elt->col < i ) + continue; + sum = sprow_inprod(CT->row+i, yny, CT->row+elt->col); + sp_set_val(CTC, i, elt->col, sum); + } + } + } + + if ( !CTC->flag_diag ) + sp_diag_access(CTC); + + return CTC; +} + +//-------------------------------------------------------------------------- +Hqp_IpLQDOCP::Hqp_IpLQDOCP() +{ + + // _wz_tol = 1.0e6; + // _wz_tol = 1.0e8; + _wz_tol = HUGE_VAL; + // _ge_tol = 1.0e-8; + _ge_tol = 1.0e-6; + // _a_sparse = 1; + _a_sparse = 0; + + _kmax = -1; + Gxx = MNULL; + m1 = MNULL; + m2 = MNULL; + Gx = VNULL; + Gu = VNULL; + ax = MNULL; + au = MNULL; + yny = VNULL; + v1 = VNULL; + v2 = VNULL; + ct = VNULL; + yb = VNULL; + Z = MNULL; + pivot = PNULL; + blocks = PNULL; + _ra = IVNULL; + _rc = IVNULL; + _rak = IVNULL; + _rck = IVNULL; + _rcka = IVNULL; + _rca = IVNULL; + _Q_ori = SMNULL; + _A_ori = SMNULL; + _C_ori = SMNULL; + _Z_ori = VNULL; + _W_ori = VNULL; + _WZ_ori = VNULL; + _CT = SMNULL; + _CTC = SMNULL; + _AT = SMNULL; + + db = MNULL; + d22 = MNULL; + + // residuum 02/21/97 + _res1 = VNULL; + _res2 = VNULL; + _res3 = VNULL; + _res4 = VNULL; + + // different number of variables per stage 02/22/97 + _nk = IVNULL; + _mk = IVNULL; + _nmk = IVNULL; + _nks = IVNULL; + _indk = IVNULL; + + // diagonal scaling + scx0 = VNULL; + + pr_("\nLQDOCP::Hqp_IpLQDOCP"); + // mem_info(); + + // _sbw = -1; + // _ifList.append(new If_Int("mat_sbw", &_sbw)); + // _ifList.append(new If_Float("mat_tol", &_tol)); + + _logging = 0; + + _ifList.append(new If_Float("mat_wz_tol", &_wz_tol)); + _ifList.append(new If_Int("mat_a_sparse", &_a_sparse)); + _ifList.append(new If_Int("mat_logging", &_logging)); +} + +//-------------------------------------------------------------------------- +Hqp_IpLQDOCP::~Hqp_IpLQDOCP() +{ + free(); + pr_("\nLQDOCP::~Hqp_IpLQDOCP"); +} + +//-------------------------------------------------------------------------- +// Get DOCP parameters from sparsity structure of qp->A. +// _kmax: number of stages +// _nk: number of states of the stage +// _mk: number of controls of the stage +// _nmk: number of states and controls up to the stage +// _nks: number of states up to the stage +// _indk: stage of qp variable +// +// E. Arnold 10/07/96 +// 02/22/97 _nk, _mk, _nmk, _indk +//-------------------------------------------------------------------------- +int Hqp_IpLQDOCP::Get_Dim(const Hqp_Program *qp) +{ + int i, k, nk, il, icl, icl1, icl_; + + if ( qp->A->m == 0 ) + return 0; + + _kmax = 0; + nk = 0; + icl_ = -1; + for ( i = 0; i < qp->A->m; i++ ) { + il = qp->A->row[i].len; + if ( il <= 1 ) + return 0; + if ( qp->A->row[i].elt[il-1].val != -1.0 ) + return 0; + icl = qp->A->row[i].elt[il-1].col; + icl1 = qp->A->row[i].elt[il-2].col; + if ( icl <= icl_ ) + return 0; + if ( ( icl - icl_ > 1 ) || ( icl - icl1 < nk ) ) { + _kmax++; + nk = 1; + } else + nk++; + icl_ = icl; + if ( icl == qp->A->n-1 ) + break; + if ( i == qp->A->m-1 ) + return 0; + } + if ( _kmax == 0 ) + return 0; + _kmax1 = _kmax-1; + + _nk = iv_resize(_nk, _kmax+1); + _nk = iv_zero(_nk); + _mk = iv_resize(_mk, _kmax); + _mk = iv_zero(_mk); + _nmk = iv_resize(_nmk, _kmax+1); + _nmk = iv_zero(_nmk); + _nks = iv_resize(_nks, _kmax+1); + _nks = iv_zero(_nks); + _indk = iv_resize(_indk, qp->A->n); + _indk = iv_zero(_indk); + + k = 0; + nk = 0; + icl_ = -1; + for ( i = 0; i < qp->A->m; i++ ) { + il = qp->A->row[i].len; + icl = qp->A->row[i].elt[il-1].col; + icl1 = qp->A->row[i].elt[il-2].col; + if ( ( icl - icl_ > 1 ) || ( icl - icl1 < nk ) ) { + if ( k > 0 ) + iv_set_val(_nk, k, nk); + k++; + iv_set_val(_nmk, k, icl); + nk = 1; + } else + nk++; + icl_ = icl; + if ( icl == qp->A->n-1 ) { + iv_set_val(_nk, k, nk); + break; + } + } + iv_set_val(_nk, 0, min(iv_entry(_nk, 1), iv_entry(_nmk, 1))); // 1999-08-20 + for ( k = 0; k <= _kmax; k++ ) + if ( ( iv_entry(_nk, k) < 0 ) || ( iv_entry(_nmk, k) < 0 ) ) + return 0; + for ( k = 0; k < _kmax; k++ ) { + iv_set_val(_mk, k, iv_entry(_nmk, k+1)-iv_entry(_nmk, k)-iv_entry(_nk, k)); + if ( iv_entry(_mk, k) < 0 ) + return 0; + } + for ( k = 1; k <= _kmax; k++ ) + iv_set_val(_nks, k, iv_entry(_nks, k-1)+iv_entry(_nk, k)); + + for ( k = 0; k < _kmax; k++ ) + for ( i = iv_entry(_nmk, k); i < iv_entry(_nmk, k+1); i++ ) + iv_set_val(_indk, i, k); + for ( i = iv_entry(_nmk, _kmax); i < (int) _indk->dim; i++ ) + iv_set_val(_indk, i, _kmax); + + return 1; +} + +//-------------------------------------------------------------------------- +// Check structure of matrices qp->Q, qp->A, qp->C. +// Returns ok = 1, if structure fits into previously determined +// DOCP structure with _kmax, _n, _m, _ra, _rc. +// Checks for fixed initial state. +// +// E. Arnold 10/07/96 +// 02/22/97 _nk, _mk, _nmk, _indk, initial state +//-------------------------------------------------------------------------- +int Hqp_IpLQDOCP::Check_Structure(const Hqp_Program *qp) +{ + int i, k, k_, ok = 1; + + // check DOCP structure of matrix A + k_ = 0; + for (i = 0; i < _nks[_kmax]; i++) { + ok = ok && (qp->A->row[i].len >= 2) && + (qp->A->row[i].elt[qp->A->row[i].len-1].val == -1.0); + if ( !ok ) return ok; + k = iv_entry(_indk, qp->A->row[i].elt[0].col); + ok = ok && ( ( k == k_ ) || ( k == k_+1 ) ) && + ( iv_entry(_indk, qp->A->row[i].elt[qp->A->row[i].len-2].col) == k ) && + ( iv_entry(_indk, qp->A->row[i].elt[qp->A->row[i].len-1].col) == k+1 ); + k_ = k; + } + for (i = _nks[_kmax]; i < qp->A->m; i++) { + ok = ok && (qp->A->row[i].len >= 1); + if ( !ok ) return ok; + k = iv_entry(_ra, i-_nks[_kmax]); + ok = ok && + ( iv_entry(_indk, qp->A->row[i].elt[0].col) == k ) && + ( iv_entry(_indk, qp->A->row[i].elt[qp->A->row[i].len-1].col) == k); + } + + // check DOCP structure of matrix C + for (i = 0; i < qp->C->m; i++) { + ok = ok && (qp->C->row[i].len >= 1); + if ( !ok ) return ok; + k = iv_entry(_rc, i); + ok = ok && + ( iv_entry(_indk, qp->C->row[i].elt[0].col) == k ) && + ( iv_entry(_indk, qp->C->row[i].elt[qp->C->row[i].len-1].col) == k ); + } + + // check DOCP structure of matrix Q + for (i = 0; i < qp->Q->m; i++) { + ok = ok && (qp->Q->row[i].len >= 1); + if ( !ok ) return ok; + k = iv_entry(_indk, i); + ok = ok && + ( iv_entry(_indk, qp->Q->row[i].elt[0].col) == k ) && + ( iv_entry(_indk, qp->Q->row[i].elt[qp->Q->row[i].len-1].col) == k ); + } + + // check for fixed initial state + _fixed_x0 = ( (int) _raki[0]->dim == iv_entry(_nk, 0) ); + if ( _fixed_x0 ) + for ( i = 0; i < (int) _raki[0]->dim; i++ ) { + _fixed_x0 = _fixed_x0 && + ( qp->A->row[iv_entry(_raki[0], i)].len == 1 ) && + ( qp->A->row[iv_entry(_raki[0], i)].elt[0].col == i ) && + ( qp->A->row[iv_entry(_raki[0], i)].elt[0].val == 1.0 ); + } + + return ok; +} + +//-------------------------------------------------------------------------- +// Get DOCP structure of constraints. +// _ra: stage of equality constraint +// _rak: number of equality constraints of the stage +// _raki: indices of the equality constraints of the stage +// _rc: stage of inequality constraint +// _rck: number of inequality constraints of the stage +// _rcki: indices of the inequality constraints of the stage +// +// E. Arnold 10/07/96 +// 02/22/97 _nk, _indk +//-------------------------------------------------------------------------- +void Hqp_IpLQDOCP::Get_Constr_Dim(const Hqp_Program *qp) +{ + int i, j, k; + + // get time step for equality constraints + _ra = iv_resize(_ra, qp->A->m-_nks[_kmax]); + _rak = iv_resize(_rak, _kmax+1); + _rak = iv_zero(_rak); + for ( i = _nks[_kmax]; i < qp->A->m; i++ ) { + k = iv_entry(_indk, qp->A->row[i].elt[0].col); + iv_set_val(_ra , i-_nks[_kmax], k); + iv_add_val(_rak, k, 1); + } + for ( k = 0; k <= _kmax; k++ ) { + _raki[k] = iv_resize(_raki[k], iv_entry(_rak, k)); + for ( i = _nks[_kmax], j = 0; i < qp->A->m; i++ ) + if ( iv_entry(_ra, i-_nks[_kmax]) == k ) { + iv_set_val(_raki[k], j, i); + j++; + } + } + + // get time step for inequality constraints + _rc = iv_resize(_rc, qp->C->m); + _rck = iv_resize(_rck, _kmax+1); + _rck = iv_zero(_rck); + for ( i = 0; i < qp->C->m; i++ ) { + k = iv_entry(_indk, qp->C->row[i].elt[0].col); + iv_set_val(_rc, i, k); + iv_add_val(_rck, k, 1); + } + for ( k = 0; k <= _kmax; k++ ) { + _rcki[k] = iv_resize(_rcki[k], iv_entry(_rck, k)); + for ( i = j = 0; i < qp->C->m; i++ ) + if ( iv_entry(_rc, i) == k ) { + iv_set_val(_rcki[k], j, i); + j++; + } + } +} + +//-------------------------------------------------------------------------- +// Allocate memory. +// +// E. Arnold 10/07/96 +// 02/22/97 _nk, _mk +//-------------------------------------------------------------------------- +void Hqp_IpLQDOCP::resize() +{ + assert(_kmax >= 1); + + Vxx.resize(_kmax); + Gxu.resize(_kmax1); + Guu.resize(_kmax1); + CH_Guu.resize(_kmax1); + CH_Guu_p.resize(_kmax1); + CH_Guu_b.resize(_kmax1); + Vx.resize(_kmax); + cb.resize(_kmax); + S.resize(_kmax1); + cbx.resize(_kmax); + ctx.resize(_kmax1); + x.resize(_kmax); + u.resize(_kmax1); + p.resize(_kmax1); + gx.resize(_kmax); + gu.resize(_kmax1); + f.resize(_kmax1); + Ru.resize(_kmax1); + if ( _a_sparse ) { + fx.free(); + fu.free(); + } else { + fx.resize(_kmax1); + fu.resize(_kmax1); + } + Rux.resize(_kmax1); + ax = m_resize(ax, 1, 1); + au = m_resize(au, 1, 1); + a.resize(_kmax); + y.resize(_kmax); + Ryx.resize(_kmax1); + Ry.resize(_kmax1); + PQ.resize(_kmax1); + + m1 = m_resize(m1, 1, 1); + m2 = m_resize(m2, 1, 1); + Gxx = m_resize(Gxx, 1, 1); + v1 = v_resize(v1, 1); + v2 = v_resize(v2, 1); + Gx = v_resize(Gx, 1); + Gu = v_resize(Gu, 1); + ct = v_resize(ct, 1); + yb = v_resize(yb, 1); + Z = m_resize(Z, 1, 1); + + _raki.resize(_kmax); + _rcki.resize(_kmax); + _rckai.resize(_kmax); + + _Q_ori = SMNULL; + if ( _a_sparse ) // 06/30/97 copy _A_ori, _C_ori + SP_FREE(_A_ori); + else + _A_ori = SMNULL; + SP_FREE(_C_ori); + _Z_ori = v_resize(_Z_ori, 1); + _W_ori = v_resize(_W_ori, 1); + _WZ_ori = v_resize(_WZ_ori, 1); + SP_FREE(_CT); + SP_FREE(_CTC); + SP_FREE(_AT); + + yny = v_resize(yny, 1); + db = m_resize(db, 1, 1); + d11.resize(_kmax1); + d12.resize(_kmax1); + d22 = m_resize(d22, 1, 1); + Ruyb.resize(_kmax1); + Ryyb.resize(_kmax1); + CD.resize(_kmax1); + CD_p.resize(_kmax1); + + // diagonal scaling + sc.resize(_kmax1); +} + +//-------------------------------------------------------------------------- +void Hqp_IpLQDOCP::free() +{ + Vxx.free(); + Gxu.free(); + Guu.free(); + CH_Guu.free(); + CH_Guu_p.free(); + CH_Guu_b.free(); + Vx.free(); + cb.free(); + S.free(); + cbx.free(); + ctx.free(); + x.free(); + u.free(); + p.free(); + gx.free(); + gu.free(); + f.free(); + Ru.free(); + fx.free(); + fu.free(); + Rux.free(); + M_FREE(ax); + M_FREE(au); + a.free(); + y.free(); + Ryx.free(); + Ry.free(); + PQ.free(); + + M_FREE(m1); + M_FREE(m2); + M_FREE(Gxx); + V_FREE(v1); + V_FREE(v2); + V_FREE(Gx); + V_FREE(Gu); + V_FREE(ct); + V_FREE(yb); + M_FREE(Z); + PX_FREE(pivot); + PX_FREE(blocks); + + IV_FREE(_ra); + IV_FREE(_rc); + IV_FREE(_rak); + IV_FREE(_rck); + IV_FREE(_rcka); + IV_FREE(_rca); + _raki.free(); + _rcki.free(); + _rckai.free(); + + // _Q_ori is a reference! + _Q_ori = SMNULL; + if ( _a_sparse ) // 06/30/97 copy _A_ori, _C_ori + SP_FREE(_A_ori); + else + _A_ori = SMNULL; + SP_FREE(_C_ori); + V_FREE(_Z_ori); + V_FREE(_W_ori); + V_FREE(_WZ_ori); + SP_FREE(_CT); + SP_FREE(_CTC); + SP_FREE(_AT); + + V_FREE(yny); + M_FREE(db); + d11.free(); + d12.free(); + M_FREE(d22); + Ruyb.free(); + Ryyb.free(); + CD.free(); + CD_p.free(); + + // residuum 02/21/97 + V_FREE(_res1); + V_FREE(_res2); + V_FREE(_res3); + V_FREE(_res4); + + // different number of variables per stage 02/22/97 + IV_FREE(_nk); + IV_FREE(_mk); + IV_FREE(_nmk); + IV_FREE(_nks); + IV_FREE(_indk); + + // diagonal scaling + V_FREE(scx0); + sc.free(); +} + +//-------------------------------------------------------------------------- +void Hqp_IpLQDOCP::dump(char *fname) +{ + int k; + FILE *fp; + char *s1 = "=========="; + + fp = fopen(fname, "w"); + fprintf(fp, "%s%s Hqp_IpLQDOCP::dump %s%s\n", s1, s1, s1, s1); + fprintf(fp, "_kmax = %d\n", _kmax); + fprintf(fp, "_nk: "); iv_foutput(fp, _nk); + fprintf(fp, "_mk: "); iv_foutput(fp, _mk); + fprintf(fp, "_nmk: "); iv_foutput(fp, _nmk); + fprintf(fp, "_nks: "); iv_foutput(fp, _nks); + fprintf(fp, "_indk: "); iv_foutput(fp, _indk); + + for ( k = 0; k <= _kmax; k++) { + fprintf(fp, "\n%s%s k = %d %s%s\n\n", s1, s1, k, s1, s1); + fprintf(fp, "\n%s gx[%d]: ", s1, k); v_foutput(fp, gx[k]); + if ( k < _kmax ) { + fprintf(fp, "\n%s gu[%d]: ", s1, k); v_foutput(fp, gu[k]); + if ( ! _a_sparse ) { + fprintf(fp, "\n%s fx[%d]: ", s1, k); m_foutput(fp, fx[k]); + fprintf(fp, "\n%s fu[%d]: ", s1, k); m_foutput(fp, fu[k]); + } + fprintf(fp, "\n%s f[%d]: ", s1, k); v_foutput(fp, f[k]); + } + + fprintf(fp, "\n%s _raki[%d]: ", s1, k); iv_foutput(fp, _raki[k]); + fprintf(fp, "\n%s _rcki[%d]: ", s1, k); iv_foutput(fp, _rcki[k]); + fprintf(fp, "\n%s _rckai[%d]: ", s1, k); iv_foutput(fp, _rckai[k]); + + fprintf(fp, "\n%s a[%d]: ", s1, k); v_foutput(fp, a[k]); + + if ( k < _kmax ) { + fprintf(fp, "\n%s Gxu[%d]: ", s1, k); m_foutput(fp, Gxu[k]); + fprintf(fp, "\n%s Guu[%d]: ", s1, k); m_foutput(fp, Guu[k]); + fprintf(fp, "\n%s S[%d]: ", s1, k); m_foutput(fp, S[k]); + fprintf(fp, "\n%s PQ[%d]: ", s1, k); m_foutput(fp, PQ[k]); + fprintf(fp, "\n%s CH_Guu[%d]: ", s1, k); m_foutput(fp, CH_Guu[k]); + fprintf(fp, "\n%s CH_Guu_p[%d]: ", s1, k); + px_foutput(fp, CH_Guu_p[k]); + fprintf(fp, "\n%s CH_Guu_b[%d]: ", s1, k); + px_foutput(fp, CH_Guu_b[k]); + fprintf(fp, "\n%s ctx[%d]: ", s1, k); m_foutput(fp, ctx[k]); + fprintf(fp, "\n%s d11[%d]: ", s1, k); m_foutput(fp, d11[k]); + fprintf(fp, "\n%s d12[%d]: ", s1, k); m_foutput(fp, d12[k]); + fprintf(fp, "\n%s CD[%d]: ", s1, k); m_foutput(fp, CD[k]); + fprintf(fp, "\n%s CD_p[%d]: ", s1, k); px_foutput(fp, CD_p[k]); + + fprintf(fp, "\n%s Rux[%d]: ", s1, k); m_foutput(fp, Rux[k]); + fprintf(fp, "\n%s Ruyb[%d]: ", s1, k); m_foutput(fp, Ruyb[k]); + fprintf(fp, "\n%s Ru[%d]: ", s1, k); v_foutput(fp, Ru[k]); + fprintf(fp, "\n%s Ryx[%d]: ", s1, k); m_foutput(fp, Ryx[k]); + fprintf(fp, "\n%s Ry[%d]: ", s1, k); v_foutput(fp, Ry[k]); + fprintf(fp, "\n%s Ryyb[%d]: ", s1, k); m_foutput(fp, Ryyb[k]); + } + + fprintf(fp, "\n%s Vxx[%d]: ", s1, k); m_foutput(fp, Vxx[k]); + fprintf(fp, "\n%s Vx[%d]: ", s1, k); v_foutput(fp, Vx[k]); + + fprintf(fp, "\n%s cbx[%d]: ", s1, k); m_foutput(fp, cbx[k]); + fprintf(fp, "\n%s cb[%d]: ", s1, k); v_foutput(fp, cb[k]); + + fprintf(fp, "\n%s x[%d]: ", s1, k); v_foutput(fp, x[k]); + fprintf(fp, "\n%s y[%d]: ", s1, k); v_foutput(fp, y[k]); + if ( k < _kmax ) { + fprintf(fp, "\n%s u[%d]: ", s1, k); v_foutput(fp, u[k]); + fprintf(fp, "\n%s p[%d]: ", s1, k); v_foutput(fp, p[k]); + } + } + + fprintf(fp, "\n%s Sparse %s\n", s1, s1); + fprintf(fp, "\n%s _Q_ori (symsp): ", s1); sp_foutput(fp, _Q_ori); + fprintf(fp, "\n%s _A_ori: ", s1); sp_foutput(fp, _A_ori); + fprintf(fp, "\n%s _C_ori: ", s1); sp_foutput(fp, _C_ori); + fprintf(fp, "\n%s _CTC (symsp): ", s1); sp_foutput(fp, _CTC); + fprintf(fp, "\n%s _Z_ori: ", s1); v_foutput(fp, _Z_ori); + fprintf(fp, "\n%s _W_ori: ", s1); v_foutput(fp, _W_ori); + fprintf(fp, "\n%s _WZ_ori: ", s1); v_foutput(fp, _WZ_ori); + + fprintf(fp, "\n%s Static %s\n", s1, s1); + fprintf(fp, "\n%s _rak: ", s1); iv_foutput(fp, _rak); + fprintf(fp, "\n%s _rck: ", s1); iv_foutput(fp, _rck); + fprintf(fp, "\n%s _rcka: ", s1); iv_foutput(fp, _rcka); + fprintf(fp, "\n%s m1: ", s1); m_foutput(fp, m1); + fprintf(fp, "\n%s m2: ", s1); m_foutput(fp, m2); + fprintf(fp, "\n%s v1: ", s1); v_foutput(fp, v1); + fprintf(fp, "\n%s v2: ", s1); v_foutput(fp, v2); + fclose(fp); +} + +//-------------------------------------------------------------------------- +// Initialize LQDOCP, called in the first SQP step. +// Check for DOCP structure. +// Allocate memory. +// Allocate memory for C'*D*C. +// +// E. Arnold +// 02/22/97 _nk, _mk +//-------------------------------------------------------------------------- +void Hqp_IpLQDOCP::init(const Hqp_Program *qp) +{ + int _kmax_old; + + pr_("\nLQDOCP::init "); + + _kmax_old = _kmax; + assert(Get_Dim(qp)); + if ( _kmax != _kmax_old ) + resize(); + Get_Constr_Dim(qp); + assert(Check_Structure(qp)); + + pr("\nLQDOCP::init _kmax = %d\n", _kmax); + + update(qp); +} + +//-------------------------------------------------------------------------- +// Update LQDOCP data structure, called once per SQP step. +// Check DOCP structure. +// +// E. Arnold +// 02/22/97 _nk, _mk +// 06/30/97 copy _A_ori, _C_ori +// structure of _CTC +//-------------------------------------------------------------------------- +void Hqp_IpLQDOCP::update(const Hqp_Program *qp) +{ + int i, j, k, knm, kn; + double sum; + + pr_("LQDOCP::update\n"); + + assert(Check_Structure(qp)); + + if ( _fixed_x0 ) + pr_("fixed initial state\n"); + + // do not really copy the matrix! + _Q_ori = qp->Q; + + if ( _a_sparse ) { + _A_ori = sp_copy3(qp->A, _A_ori); + sp_compact(_A_ori, 0.0); + // transpose _A_ori + _AT = sp_transp_ea(_A_ori, _AT); + } else { + _A_ori = qp->A; + SP_FREE(_AT); + + // extract coefficient matrices fx[k], fu[k] from qp->A + for ( k = 0; k < _kmax; k++ ) { + knm = _nmk[k]; + kn = _nks[k]; + fx[k] = m_resize(fx[k], _nk[k+1], _nk[k]); + sp_extract_mat(qp->A, kn, knm, fx[k]); + fu[k] = m_resize(fu[k], _nk[k+1], _mk[k]); + sp_extract_mat(qp->A, kn, knm+_nk[k], fu[k]); + } + } + + _C_ori = sp_copy3(qp->C, _C_ori); + sp_compact(_C_ori, 0.0); + + // sparsity structure of matrix _CTC (only elements (i,j), j>=i) + if ( ! _CTC ) + _CTC = sp_get(qp->Q->m, qp->Q->n, 10); + _CT = sp_transp_ea(_C_ori, _CT); + + // check DOCP structure of matrix _CT + pr_("check _C_ori"); + check_sparse(_C_ori); + pr_(" check _CT"); + check_sparse(_CT); + + _CT = sp_ones(_CT); + v1 = v_resize(v1, _CT->n); + v1 = v_ones(v1); + for ( k = 0; k <= _kmax; k++ ) { + knm = _nmk[k]; + for ( i = 0; i < (k<_kmax?_nk[k]+_mk[k]:_nk[k]); i++ ) + for ( j = i; j < (k<_kmax?_nk[k]+_mk[k]:_nk[k]); j++ ) { + sum = sprow_inprod(&(_CT->row[knm+i]), v1, + &(_CT->row[knm+j])); + if ( sum != 0.0 ) + sp_set_val(_CTC, knm+i, knm+j, sum); // _CTC is symsp! + } + } + _CT = sp_transp_ea(_C_ori, _CT); + pr_("update finished\n"); +} + +//-------------------------------------------------------------------------- +// LQDOCP factorization routine, called once per QP step. +// Form _WZ_ori, check for 'active' inequalities, form _CTC. +// +// E. Arnold +// 02/22/97 _nk, _mk +//-------------------------------------------------------------------------- +void Hqp_IpLQDOCP::factor(const Hqp_Program *qp, + const VEC *y_v, const VEC *ny_v) +{ + int i, j, k; + + assert(((int)y_v->dim == _C_ori->m) && (ny_v->dim == y_v->dim)); + pr_("LQDOCP::factor:\n"); + // mem_info(); + + _Z_ori = v_copy1(y_v, _Z_ori); + _W_ori = v_copy1(ny_v, _W_ori); + + // _WZ_ori = W^{-1}Z + _WZ_ori = v_resize(_WZ_ori, _Z_ori->dim); + _WZ_ori = v_slash(_W_ori, _Z_ori, _WZ_ori); + + // 'active' constraints + _rca = iv_resize(_rca, _WZ_ori->dim); + for ( i = 0; i < (int) _WZ_ori->dim; i++ ) + if ( v_entry(_WZ_ori, i)*sprow_norm2(&(_C_ori->row[i])) > _wz_tol ) + // if ( v_entry(_WZ_ori, i) > _wz_tol ) + iv_set_val(_rca, i, 1); + else + iv_set_val(_rca, i, 0); + + // _CTC = C^T(W^{-1}Z)C + v1 = v_copy1(_WZ_ori, v1); + for ( i = 0; i < (int) v1->dim; i++ ) + if ( iv_entry(_rca, i) ) + v_set_val(v1, i, 0.0); + _CTC = CTDC(_CT, v1, _CTC); + + // set diagonal access paths for _Q_ori and _CTC + if ( !_Q_ori->flag_diag ) + sp_diag_access(_Q_ori); + if ( !_CTC->flag_diag ) + sp_diag_access(_CTC); + + // indices of 'active' inequality contraints + _rcka = iv_resize(_rcka, _kmax+1); + _rcka = iv_zero(_rcka); + for ( k = 0; k <= _kmax; k++ ) + for ( i = 0; i < iv_entry(_rck, k); i++ ) + if ( iv_entry(_rca, iv_entry(_rcki[k], i)) ) + iv_add_val(_rcka, k, 1); + for ( k = 0; k <= _kmax; k++ ) { + _rckai[k] = iv_resize(_rckai[k], iv_entry(_rcka, k)); + for ( i = 0, j = 0; i < iv_entry(_rck, k); i++ ) + if ( iv_entry(_rca, iv_entry(_rcki[k], i)) ) { + iv_set_val(_rckai[k], j, iv_entry(_rcki[k], i)); + j++; + } + } + // printf("vor ExRiccatiFactor\n"); + if ( _wz_tol != HUGE_VAL ) + ExRiccatiFactor(); + else + ExRiccatiFactorSc(); + + for ( k = 0, i = 0, j = 0; k <= _kmax; k++ ) { + i += iv_entry(_rcka, k); + if ( k < _kmax ) j = ((int)PQ[k]->m>j)? PQ[k]->m: j; + // if ( k < _kmax ) j = ((int)CH_Guu[k]->m>j)? CH_Guu[k]->m: j; + } + // printf(" %d 'active' inequalities, max(dim(PQ)) = %d\n", i, j); + // printf(" %d 'active' inequalities, max(dim(CH_Guu)) = %d\n", i, j); +} + +//-------------------------------------------------------------------------- +// Solve the IP-Newton system. +// E. Arnold +// 2/21/97 iterative improvement +//-------------------------------------------------------------------------- +void Hqp_IpLQDOCP::step(const Hqp_Program *qp, + const VEC *y_v, const VEC *ny_v, + const VEC *r1, const VEC *r2, const VEC *r3, + const VEC *r4, VEC *dx, VEC *dy, VEC *dz, VEC *dw) +{ + int k, i, knm, kn; + double res; + + assert((int)r1->dim == _Q_ori->m && (int)dx->dim == _Q_ori->m); + assert((int)r2->dim == _A_ori->m && (int)dy->dim == _A_ori->m); + assert((int)r3->dim == _C_ori->m && (int)dz->dim == _C_ori->m); + assert((int)r4->dim == _C_ori->m && (int)dw->dim == _C_ori->m); + + pr_("LQDOCP::solve "); + + // gx, gu, f from r1, r2 + for ( k = 0; k <= _kmax; k++ ) { + knm = _nmk[k]; + kn = _nks[k]; + gx[k] = v_resize(gx[k], _nk[k]); + gx[k] = v_move(r1, knm, _nk[k], gx[k], 0); + gx[k] = sv_mlt(-1.0, gx[k], gx[k]); + a[k] = v_move_iv(r2, _raki[k], a[k]); + if ( k < _kmax ) { + gu[k] = v_resize(gu[k], _mk[k]); + gu[k] = v_move(r1, knm+_nk[k], _mk[k], gu[k], 0); + gu[k] = sv_mlt(-1.0, gu[k], gu[k]); + f[k] = v_resize(f[k], _nk[k+1]); + f[k] = v_move(r2, kn, _nk[k+1], f[k], 0); + } + } + + // modify gx, gu for reduced system + v2 = v_resize(v2, r3->dim); + v2 = v_star(_Z_ori, r3, v2); + v2 = v_add(v2, r4, v2); + v2 = v_slash(_W_ori, v2, v2); + for ( i = 0; i < (int) v2->dim; i++ ) + // if (v_entry(_WZ_ori, i) > _wz_tol ) + if ( iv_entry(_rca, i) ) + v_set_val(v2, i, 0.0); + v1 = sp_vm_mlt(_C_ori, v2, v1); + for ( k = 0; k <= _kmax; k++ ) { + knm = _nmk[k]; + v2 = v_resize(v2, _nk[k]); + v2 = v_move(v1, knm, _nk[k], v2, 0); + gx[k] = v_add(gx[k], v2, gx[k]); + if ( k < _kmax) { + v2 = v_resize(v2, _mk[k]); + v2 = v_move(v1, knm+_nk[k], _mk[k], v2, 0); + gu[k] = v_add(gu[k], v2, gu[k]); + } + } + + // append 'active' inequalities to equalities + v1 = v_resize(v1, r3->dim); + v1 = v_slash(_Z_ori, r4, v1); + v1 = v_add(r3, v1, v1); + for ( k = 0; k <= _kmax; k++ ) { + v2 = v_move_iv(v1, _rckai[k], v2); + a[k] = v_concat(a[k], v2, a[k]); + } + + if ( _wz_tol != HUGE_VAL ) + ExRiccatiSolve(); + else + ExRiccatiSolveSc(); + + // dx, dy + for ( k = 0; k <= _kmax; k++ ) { + knm = _nmk[k]; //k*nm; + kn = _nks[k]; //k*_n; + dx = v_move(x[k], 0 , _nk[k], dx, knm); + v1 = v_resize(v1, iv_entry(_rak, k)); + v1 = v_move(y[k], 0, v1->dim, v1, 0); + dy = v_set_iv(v1, _raki[k], dy); + if ( k < _kmax ) { + dx = v_move(u[k], 0 , _mk[k], dx, knm+_nk[k]); + dy = v_move(p[k], 0 , _nk[k+1], dy, kn); + } + } + + // change sign for dx + dx = sv_mlt(-1.0, dx, dx); + + // dw = C*dx-r3, dz = W^(-1)(-Z*dw+r4) + v1 = v_resize(v1, r3->dim); + v1 = sp_mv_mlt(_C_ori, dx, v1); + dw = v_sub(v1, r3, dw); + v1 = v_star(_Z_ori, dw, v1); + v1 = v_sub(r4, v1, v1); + dz = v_slash(_W_ori, v1, dz); + + // dz for 'active' constraints + for ( k = 0; k <= _kmax; k++ ) { + v1 = v_resize(v1, iv_entry(_rcka, k)); + v1 = v_move(y[k], iv_entry(_rak, k), v1->dim, v1, 0); + dz = v_set_iv(v1, _rckai[k], dz); + } + + // check residuum of IP-Newton system + Residuum(r1, r2, r3, r4, dx, dy, dz, dw, 0); + + res = v_norm_inf(_res1)+v_norm_inf(_res2)+v_norm_inf(_res3)+ + v_norm_inf(_res4); + + pr("Residuum: %g\n", res); +} + +//-------------------------------------------------------------------------- +// Calculate residuum components _res1, _res2, _res3, _res4 +// of the IP-Newton system. +// If dump != 0, dump to file fname. +// E. Arnold 2/21/97 +//-------------------------------------------------------------------------- +void Hqp_IpLQDOCP::Residuum(const VEC *r1, const VEC *r2, const VEC *r3, + const VEC *r4, const VEC *dx, const VEC *dy, + const VEC *dz, const VEC *dw, const int dump) +{ + FILE *fp = NULL; + char *fname = "dump_residuum.dat"; + + if ( dump ) + fp = fopen(fname, "w"); + + // residuum of Q*dx+A'*dy+C'*dw = r1 + v1 = v_resize(v1, r1->dim); + v1 = sp_mv_symmlt(_Q_ori, dx, v1); + v2 = sp_vm_mlt(_A_ori, dy, v2); + v1 = v_sub(v2, v1, v1); + v2 = sp_vm_mlt(_C_ori, dz, v2); + v1 = v_add(v1, v2, v1); + v1 = v_sub(v1, r1, v1); + _res1 = v_copy1(v1, _res1); + + if ( dump ) { + fprintf(fp, "===== Residuum1: %g\n", v_norm_inf(v1)); + v_foutput(fp, v1); + v1 = v_resize(v1, r1->dim); + v1 = sp_mv_symmlt(_Q_ori, dx, v1); + fprintf(fp, "===== _Q_ori*dx:"); + v_foutput(fp, v1); + v2 = sp_vm_mlt(_A_ori, dy, v2); + fprintf(fp, "===== _A_ori^T*dy:"); + v_foutput(fp, v2); + v2 = sp_vm_mlt(_C_ori, dz, v2); + fprintf(fp, "===== _C_ori^T*dz:"); + v_foutput(fp, v2); + fprintf(fp, "===== r1:"); + v_foutput(fp, r1); + } + + // residuum of A*dx = r2 + v1 = v_resize(v1, r2->dim); + v1 = sp_mv_mlt(_A_ori, dx, v1); + v1 = v_sub(v1, r2, v1); + _res2 = v_copy1(v1, _res2); + + if ( dump ) { + fprintf(fp, "\n\n===== Residuum2: %g\n", v_norm2(v1)); + v_foutput(fp, v1); + fprintf(fp, "===== r2: "); + v_foutput(fp, r2); + } + + // residuum of C*dx-dw = r3 + v1 = v_resize(v1, r3->dim); + v1 = sp_mv_mlt(_C_ori, dx, v1); + v1 = v_sub(v1, dw, v1); + v1 = v_sub(v1, r3, v1); + _res3 = v_copy1(v1, _res3); + + if ( dump ) { + fprintf(fp, "\n\n===== Residuum3: %g\n", v_norm2(v1)); + v_foutput(fp, v1); + fprintf(fp, "===== r3: "); + v_foutput(fp, r3); + } + + // residuum of W*dz+Z*dw = r4 + v1 = v_resize(v1, r4->dim); + v1 = v_star(_W_ori, dz, v1); + v2 = v_star(_Z_ori, dw, v2); + v1 = v_add(v1, v2, v1); + v1 = v_sub(v1, r4, v1); + _res4 = v_copy1(v1, _res4); + + if ( dump ) { + fprintf(fp, "\n\n===== Residuum4: %g\n", v_norm2(v1)); + v_foutput(fp, v1); + fprintf(fp, "===== dz: "); + v_foutput(fp, dz); + fprintf(fp, "===== dw: "); + v_foutput(fp, dw); + fprintf(fp, "===== r4: "); + v_foutput(fp, r4); + } + + if ( dump ) + fclose(fp); +} + +//-------------------------------------------------------------------------- +// Form Gxx = Hxx + fx'*Vxx*fx, Gxu = Hxu + fx'*Vxx*fu, +// Guu = Huu + fu'*Vxx*fu for stage k. +// Dense version. +// E. Arnold 12/02/96 +//-------------------------------------------------------------------------- +void Hqp_IpLQDOCP::FormGxx(int k) +{ + int knm = _nmk[k]; + + // Gxx = Hxx + fx'*Vxx*fx + m1 = m_resize(m1, _nk[k], _nk[k]); + Gxx = m_resize(Gxx, _nk[k], _nk[k]); + symsp_extract_mat(_Q_ori, knm, Gxx); + symsp_extract_mat(_CTC, knm, m1); + Gxx = m_add(Gxx, m1, Gxx); + m2 = mtrm_mlt(fx[k], Vxx[k+1], m2); + m1 = m_mlt(m2, fx[k], m1); + Gxx = m_add(Gxx, m1, Gxx); + Gxx = m_symm(Gxx, Gxx); + + // Gxu = Hxu + fx'*Vxx*fu + Gxu[k] = m_resize(Gxu[k], _nk[k], _mk[k]); + sp_extract_mat(_Q_ori, knm, knm+_nk[k], Gxu[k]); + m1 = m_resize(m1, _nk[k], _mk[k]); + sp_extract_mat(_CTC, knm, knm+_nk[k], m1); + Gxu[k] = m_add(Gxu[k], m1, Gxu[k]); + m1 = m_mlt(m2, fu[k], m1); + Gxu[k] = m_add(Gxu[k], m1, Gxu[k]); + + // Guu = Huu + fu'*Vxx*fu + Guu[k] = m_resize(Guu[k], _mk[k], _mk[k]); + symsp_extract_mat(_Q_ori, knm+_nk[k], Guu[k]); + m1 = m_resize(m1, _mk[k], _mk[k]); + symsp_extract_mat(_CTC, knm+_nk[k], m1); + Guu[k] = m_add(Guu[k], m1, Guu[k]); + m2 = mtrm_mlt(fu[k], Vxx[k+1], m2); + m1 = m_mlt(m2, fu[k], m1); + Guu[k] = m_add(Guu[k], m1, Guu[k]); + Guu[k] = m_symm(Guu[k], Guu[k]); +} + +//-------------------------------------------------------------------------- +// Form Gxx = Hxx + fx'*Vxx*fx, Gxu = Hxu + fx'*Vxx*fu, +// Guu = Huu + fu'*Vxx*fu for stage k. +// Sparse version. +// E. Arnold 12/02/96 +//-------------------------------------------------------------------------- +void Hqp_IpLQDOCP::FormGxxSp(int k) +{ + int knm = _nmk[k]; + int kn = _nks[k]; + int k1 = k+1; + int i, j, col, ii, j_idx; + SPROW *row; + row_elt *elt; + double val; + + // initialize Gxx, Gxu, Guu + Gxx = m_resize(Gxx, _nk[k], _nk[k]); + Gxx = m_zero(Gxx); + Gxu[k] = m_resize(Gxu[k], _nk[k], _mk[k]); + Gxu[k] = m_zero(Gxu[k]); + Guu[k] = m_resize(Guu[k], _mk[k], _mk[k]); + Guu[k] = m_zero(Guu[k]); + + // build m1 = [f_x^T; f_u^T]*Vxx + m1 = m_resize(m1, _nk[k]+_mk[k], _nk[k+1]); + m1 = m_zero(m1); + row = _AT->row + knm; + for ( i = 0; i < _nk[k]+_mk[k]; i++, row++) { + for ( j_idx = (((k==0)||(i>=_nk[k]))?0:1); j_idx < row->len; j_idx++ ) { + j = row->elt[j_idx].col-kn; + if ( j >= _nk[k] ) + break; + val = row->elt[j_idx].val; + __mltadd__(m1->me[i], Vxx[k1]->me[j], row->elt[j_idx].val, _nk[k+1]); + } + } + + // build upper triangel of m1*[fx fu] + row = _AT->row + knm; + for ( j = 0; j < _nk[k]+_mk[k]; j++, row++ ) { + for ( j_idx = (((k==0)||(j>=_nk[k])) ? 0: 1); j_idx < row->len; j_idx++ ) { + i = row->elt[j_idx].col-kn; + if ( i >= _nk[k+1] ) + break; + val = row->elt[j_idx].val; + for ( ii = 0; ii <= j; ii++ ) { + if ( ii < _nk[k] ) + if ( j < _nk[k] ) + m_add_val(Gxx, ii, j, m_entry(m1, ii, i)*val); + else + m_add_val(Gxu[k], ii, j-_nk[k], m_entry(m1, ii, i)*val); + else + m_add_val(Guu[k], ii-_nk[k], j-_nk[k], m_entry(m1, ii, i)*val); + } + } + } + + // add _Q_ori + row = _Q_ori->row+knm; + for ( i = 0; i < _nk[k]+_mk[k]; i++, row++) { + if ( row->len > 0 ) { + if ( ( row->diag < 0 ) || ( row->diag >= row->len ) ) + error(E_INTERN, + "LQDOCP::FormGxxSp: invalid diagonal access path in FormGxx"); + elt = row->elt+row->diag; + for ( j = row->diag; j < row->len; j++, elt++ ) { + col = elt->col-knm; + if ( i < _nk[k] ) + if ( col < _nk[k] ) + m_add_val(Gxx, i, col, elt->val); + else + m_add_val(Gxu[k], i, col-_nk[k], elt->val); + else + m_add_val(Guu[k], i-_nk[k], col-_nk[k], elt->val); + } + } + } + + // add _CTC + row = _CTC->row+knm; + for ( i = 0; i < _nk[k]+_mk[k]; i++, row++) { + if ( row->len > 0 ) { + if ( ( row->diag < 0 ) || ( row->diag >= row->len ) ) + error(E_INTERN, + "LQDOCP::FormGxxSp: invalid diagonal access path in FormGxx"); + elt = row->elt+row->diag; + for ( j = row->diag; j < row->len; j++, elt++ ) { + col = elt->col-knm; + if ( i < _nk[k] ) + if ( col < _nk[k] ) + m_add_val(Gxx, i, col, elt->val); + else + m_add_val(Gxu[k], i, col-_nk[k], elt->val); + else + m_add_val(Guu[k], i-_nk[k], col-_nk[k], elt->val); + } + } + } + + // make Gxx and Guu symmetric + for ( i = 0; i < _nk[k]; i++ ) + for ( j = i+1; j < _nk[k]; j++ ) + m_set_val(Gxx, j, i, m_entry(Gxx, i, j)); + for ( i = 0; i < _mk[k]; i++ ) + for ( j = i+1; j < _mk[k]; j++ ) + m_set_val(Guu[k], j, i, m_entry(Guu[k], i, j)); +} + +//-------------------------------------------------------------------------- +// Form Gx = gx + fx'*(Vx + Vxx*f), Gu = gu + fu'*Vx + Vxx*f) +// for stage k. Dense version. +// E. Arnold 10/08/96 +//-------------------------------------------------------------------------- +void Hqp_IpLQDOCP::FormGx(int k) +{ + // Gx = gx + fx'*(Vx + Vxx*f) + v1 = mv_mlt(Vxx[k+1], f[k], v1); + v1 = v_add(v1, Vx[k+1], v1); + v2 = vm_mlt(fx[k], v1, v2); + Gx = v_add(gx[k], v2, Gx); + + // Gu = gu + fu'*(Vx + Vxx*f) + v2 = vm_mlt(fu[k], v1, v2); + Gu = v_add(gu[k], v2, Gu); +} + +//-------------------------------------------------------------------------- +// Form Gx = gx + fx'*(Vx + Vxx*f), Gu = gu + fu'*Vx + Vxx*f) +// for stage k. Sparse version. +// E. Arnold 12/12/96 +//-------------------------------------------------------------------------- +void Hqp_IpLQDOCP::FormGxSp(int k) +{ + int knm = _nmk[k]; + int kn = _nks[k]; + int i, j, j_idx; + SPROW *row; + + // initialize Gx, Gu + Gx = v_copy1(gx[k], Gx); + Gu = v_copy1(gu[k], Gu); + + // v1 = (Vx + Vxx*f) + v1 = mv_mlt(Vxx[k+1], f[k], v1); + v1 = v_add(v1, Vx[k+1], v1); + + // [Gx; Gu] = [fx'; fu']*v1 + row = _AT->row + knm; + for ( i = 0; i < _nk[k]+_mk[k]; i++, row++ ) { + for ( j_idx = (((k==0)||(i>=_nk[k]))?0:1); j_idx < row->len; j_idx++ ) { + j = row->elt[j_idx].col-kn; + if ( j >= _nk[k+1] ) + break; + if ( i < _nk[k] ) + v_add_val(Gx, i, row->elt[j_idx].val*v_entry(v1, j)); + else + v_add_val(Gu, i-_nk[k], row->elt[j_idx].val*v_entry(v1, j)); + } + } +} + +//-------------------------------------------------------------------------- +// Get ax, au, yny from _A_ori, _C_ori, _W_ori, _Z_ori +// E. Arnold 10/24/96 +// 02/22/97 _nk, _mk +//-------------------------------------------------------------------------- +void Hqp_IpLQDOCP::Formax(int k) +{ + int i, j_idx; + + // ax + ax = m_resize(ax, iv_entry(_rak, k), _nk[k]); + sp_extract_mat_iv(_A_ori, _raki[k], _nmk[k], ax); + m1 = m_resize(m1, iv_entry(_rcka, k), _nk[k]); + sp_extract_mat_iv(_C_ori, _rckai[k], _nmk[k], m1); + ax = m_concatc(ax, m1, ax); + + // au + if ( k < _kmax ) { + au = m_resize(au, iv_entry(_rak, k), _mk[k]); + sp_extract_mat_iv(_A_ori, _raki[k], _nmk[k]+_nk[k], au); + m1 = m_resize(m1, iv_entry(_rcka, k), _mk[k]); + sp_extract_mat_iv(_C_ori, _rckai[k], _nmk[k]+_nk[k], m1); + au = m_concatc(au, m1, au); + } + + // yny + yny = v_resize(yny, iv_entry(_rak, k)+iv_entry(_rcka, k)); + yny = v_zero(yny); + for ( i = 0; i < iv_entry(_rcka, k); i++ ) { + j_idx = iv_entry(_rckai[k], i); + v_set_val(yny, iv_entry(_rak, k)+i, + (v_entry(_W_ori, j_idx))/(v_entry(_Z_ori, j_idx))); + } + + // remove fixed initial states + if ( ( k == 0 ) && ( _fixed_x0 ) ) { + m1 = m_resize(m1, ax->m-_nk[k], ax->n); + m1 = m_move(ax, _nk[k], 0, m1->m, m1->n, m1, 0, 0); + ax = m_copy1(m1, ax); + m1 = m_resize(m1, au->m-_nk[k], au->n); + m1 = m_move(au, _nk[k], 0, m1->m, m1->n, m1, 0, 0); + au = m_copy1(m1, au); + v1 = v_resize(v1, yny->dim-_nk[k]); + v1 = v_move(yny, _nk[k], v1->dim, v1, 0); + yny = v_copy1(v1, yny); + } +} + +//-------------------------------------------------------------------------- +// Extended Riccati solution: factorization routine. +// E. Arnold 10/08/96 +// 02/22/97 _nk, _mk +//-------------------------------------------------------------------------- +void Hqp_IpLQDOCP::ExRiccatiFactor(void) +{ + int k, i, k1, kn, knm; + + // Final stage: set Vxx, cbx, db for _kmax. + + Vxx[_kmax] = m_resize(Vxx[_kmax], _nk[_kmax], _nk[_kmax]); + symsp_extract_mat(_Q_ori, _nmk[_kmax], Vxx[_kmax]); + m1 = m_resize(m1, _nk[_kmax], _nk[_kmax]); + symsp_extract_mat(_CTC, _nmk[_kmax], m1); + Vxx[_kmax] = m_add(Vxx[_kmax], m1, Vxx[_kmax]); + + Formax(_kmax); + cbx[_kmax] = m_copy1(ax, cbx[_kmax]); + + db = m_resize(db, cbx[_kmax]->m, cbx[_kmax]->m); + db = m_zero(db); + if ( v_norm1(yny) > 0.0 ) + for ( i = 0; i < (int) yny->dim; i++ ) + m_set_val(db, i, i, -v_entry(yny, i)); + + // Backward run: calculate Vxx, Rux, Ryx for k=_kmax-1, ... ,0. + + for (k = _kmax-1; k >= 0; k--) { + k1 = k+1; + kn = _nks[k]; + knm = _nmk[k]; + + // Gxx, Gxu, Guu + if ( !_a_sparse ) + FormGxx(k); + else + FormGxxSp(k); + + // printf("vor Formax\n"); + // ax, au, yny + Formax(k); + + // m2 = cbu + // printf("vor cbu\n"); + if ( _a_sparse ) + m1 = mbsptr_mlt(cbx[k1], _AT, kn, knm+_nk[k], _mk[k], m1); + else + m1 = m_mlt(cbx[k1], fu[k], m1); + m2 = m_concatc(au, m1, m2); + + // Generalized elimination + if ( (MAT *)Z == MNULL ) + Z = m_resize(Z, 1, 1); // Z must be allocated for GE_QP()! + GE_QP(m2, S[k], Z, PQ[k], _ge_tol); + + // cbx + if ( _a_sparse ) + m1 = mbsptr_mlt(cbx[k1], _AT, kn, knm, _nk[k], m1); + else + m1 = m_mlt(cbx[k1], fx[k], m1); + m2 = m_concatc(ax, m1, m2); + cbx[k] = mtrm_mlt(PQ[k], m2, cbx[k]); + + // d11, d12, d22 for 'active' inequalities + d11[k] = m_resize(d11[k], S[k]->n, S[k]->n); + d12[k] = m_resize(d12[k], S[k]->n, cbx[k]->m-S[k]->n); + d22 = m_resize(d22, cbx[k]->m-S[k]->n, cbx[k]->m-S[k]->n); + if ( ( m_norm1(db) > 0.0 ) || ( v_norm1(yny) > 0.0 ) ) { + m1 = m_resize(m1, cbx[k]->m, cbx[k]->m); + m1 = m_zero(m1); + if ( v_norm1(yny) > 0.0 ) + for ( i = 0; i < (int) yny->dim; i++ ) + m_set_val(m1, i, i, -v_entry(yny, i)); + if ( m_norm1(db) > 0.0 ) + m1 = m_move(db, 0, 0, db->m, db->n, m1, yny->dim, yny->dim); + m2 = m_mlt(m1, PQ[k], m2); + m1 = mtrm_mlt(PQ[k], m2, m1); + d11[k] = m_move(m1, 0, 0, d11[k]->m, d11[k]->n, d11[k], 0, 0); + d12[k] = m_move(m1, 0, S[k]->n, d12[k]->m, d12[k]->n, d12[k], 0, 0); + d22 = m_move(m1, S[k]->n, S[k]->n, d22->m, d22->n, d22, 0, 0); + } else { + + // d11, d12, d22 for no 'active' inequalities + d11[k] = m_zero(d11[k]); + d12[k] = m_zero(d12[k]); + d22 = m_zero(d22); + } + + if ( S[k]->n == 0 ) { + + // CH_Guu for unconstrained u: CH_Guu is CHfactor! + CH_Guu[k] = m_copy1(Guu[k], CH_Guu[k]); + // printf("CH_Guu[%d]: ", k); m_output(CH_Guu[k]); + // CH_Guu[k] = CHfactor(CH_Guu[k]); + CH_Guu_p[k] = px_resize(CH_Guu_p[k], CH_Guu[k]->m); + CH_Guu_b[k] = px_resize(CH_Guu_b[k], CH_Guu[k]->m); + CH_Guu[k] = BKPfactor(CH_Guu[k], CH_Guu_p[k], CH_Guu_b[k]); + + // Rux, Ryx, Ruyb, Ryyb, ctx for unconstrained u + // Rux[k] = CHsolveMT(CH_Guu[k], Gxu[k], Rux[k]); + Rux[k] = BKPsolveMT(CH_Guu[k], CH_Guu_p[k], CH_Guu_b[k], Gxu[k], Rux[k]); + Ryx[k] = m_resize(Ryx[k], 0, _nk[k]); + Ruyb[k] = m_resize(Ruyb[k], _mk[k], d22->m); + Ruyb[k] = m_zero(Ruyb[k]); + Ryyb[k] = m_resize(Ryyb[k], 0, d22->m); + ctx[k] = m_resize(ctx[k], 0, _nk[k]); + } else { + + // ctx + ctx[k] = m_resize(ctx[k], S[k]->n, _nk[k]); + ctx[k] = m_move(cbx[k], 0, 0, S[k]->n, _nk[k], ctx[k], 0, 0); + + // Rux, m2 = cttilx + m1 = mmtr_mlt(d11[k], S[k], m1); + m2 = mmtr_mlt(m1, Gxu[k], m2); + m2 = m_sub(ctx[k], m2, m2); + Rux[k] = m_mlt(S[k], m2, Rux[k]); + Ruyb[k] = m_mlt(S[k], d12[k], Ruyb[k]); + + // cbx + // i = cbx[k]->m-S[k]->n; + m1 = m_resize(m1, cbx[k]->m-S[k]->n, _nk[k]); + m1 = m_move(cbx[k], S[k]->n, 0, m1->m, _nk[k], m1, 0, 0); + cbx[k] = m_copy1(m1, cbx[k]); + + if ( (int) S[k]->n < _mk[k] ) { + + // CH_Guu for constrained u + m1 = m_mlt(Guu[k], Z, m1); + CH_Guu[k] = mtrm_mlt(Z, m1, CH_Guu[k]); + // CH_Guu[k] = CHfactor(CH_Guu[k]); + // m2 = CHsolveMT(CH_Guu[k], Z, m2); + pivot = px_resize(pivot, CH_Guu[k]->m); + blocks = px_resize(blocks, CH_Guu[k]->m); + CH_Guu[k] = BKPfactor(CH_Guu[k], pivot, blocks); + m2 = BKPsolveMT(CH_Guu[k], pivot, blocks, Z, m2); + CH_Guu[k] = m_mlt(Z, m2, CH_Guu[k]); + + // Rux for constrained u + m1 = m_mlt(Guu[k], Rux[k], m1); + m2 = m_transp(Gxu[k], m2); + m1 = m_sub(m2, m1, m1); + m2 = m_mlt(CH_Guu[k], m1, m2); + Rux[k] = m_add(m2, Rux[k], Rux[k]); + + // Ruyb for constrained u + m1 = m_mlt(Guu[k], Ruyb[k], m1); + m2 = m_mlt(CH_Guu[k], m1, m2); + Ruyb[k] = m_sub(Ruyb[k], m2, Ruyb[k]); + } + + // correction of Rux, Ruyb + if ( ( m_norm1(db) > 0.0 ) || ( v_norm1(yny) > 0.0 ) ) { + m1 = mtrm_mlt(S[k], Guu[k], m1); + m2 = m_mlt(d11[k], m1, m2); + CD[k] = m_mlt(S[k], m2, CD[k]); + if ( (int) S[k]->n < _mk[k] ) { + m1 = m_mlt(Guu[k], CD[k], m1); + m2 = m_mlt(CH_Guu[k], m1, m2); + CD[k] = m_sub(CD[k], m2, CD[k]); + } + m1 = m_resize(m1, _mk[k], _mk[k]); + m1 = m_ident(m1); + CD[k] = m_sub(m1, CD[k], CD[k]); + // printf("CD[%d]: ", k); m_output(CD[k]); + CD_p[k] = px_resize(CD_p[k], CD[k]->m); + CD[k] = LUfactor(CD[k], CD_p[k]); + { + Real cond = LUcondest(CD[k], CD_p[k]); + if ( _logging && cond > 1.0e10 ) + fprintf(stderr, "LQDOCP: cond(CD[%d]): %g\n", k, cond); + } + Rux[k] = LUsolveM(CD[k], CD_p[k], Rux[k], Rux[k]); + Ruyb[k] = LUsolveM(CD[k], CD_p[k], Ruyb[k], Ruyb[k]); + } else + CD[k] = m_resize(CD[k], 0, 0); + + // Ryx + m1 = m_transp(Gxu[k], m1); + m2 = m_mlt(Guu[k], Rux[k], m2); + m1 = m_sub(m1, m2, m1); + Ryx[k] = mtrm_mlt(S[k], m1, Ryx[k]); + + // Ryyb + m1 = m_mlt(Guu[k], Ruyb[k], m1); + Ryyb[k] = mtrm_mlt(S[k], m1, Ryyb[k]); + Ryyb[k] = sm_mlt(-1.0, Ryyb[k], Ryyb[k]); + } + + // Vxx + m1 = m_mlt(Gxu[k], Rux[k], m1); + Vxx[k] = m_sub(Gxx, m1, Vxx[k]); + if (Ryx[k]->m > 0) { + m1 = mtrm_mlt(ctx[k], Ryx[k], m1); + Vxx[k] = m_sub(Vxx[k], m1, Vxx[k]); + } + + // check for symmetry of Vxx + if ( _logging && rel_symm(Vxx[k]) > 1e-8 ) { + fprintf(stderr, + "LQDOCP: symmetry check Vxx[%d]: %g\n", k, rel_symm(Vxx[k])); + if ( rel_symm(Vxx[k]) > 1e-3 ) { + m_foutput(stderr, Vxx[k]); + // dump(); + // error(E_POSDEF,"ExRiccatiFactor"); + } + } + Vxx[k] = m_symm(Vxx[k], Vxx[k]); + + if ( S[k]->n > 0 ) { + + // check for symmetry of cbx + m1 = m_mlt(Gxu[k], Ruyb[k], m1); + m2 = m_transp(m1, m2); + m1 = mtrm_mlt(Ryyb[k], ctx[k], m1); + m2 = m_add(m1, m2, m2); + m2 = m_sub(cbx[k], m2, m2); + + // cbx + m1 = mtrm_mlt(d12[k], Ryx[k], m1); + cbx[k] = m_sub(cbx[k], m1, cbx[k]); + m1 = m_sub(cbx[k], m2, m1); + if ( m_norm1(m1) > 1e-8 ) { + fprintf(stderr, "LQDOCP: symmetry check (k=%d):\n", k); + fprintf(stderr, "cbx1: "); m_output(cbx[k]); + fprintf(stderr, "cbx2: "); m_output(m2); + dump(); + error(E_POSDEF,"LQDOCP::ExRiccatiFactor"); + } + + // db + m1 = mtrm_mlt(d12[k], Ryyb[k], m1); + db = m_sub(d22, m1, db); + + // check for symmetry of db + m1 = m_transp(db, m1); + m1 = m_sub(m1, db, m1); + if ( _logging && m_norm1(m1) > 1e-8 ) { + fprintf(stderr, "LQDOCP: symmetry check db[%d]:\n", k); + m_foutput(stderr, db); + dump(); + error(E_POSDEF,"LQDOCP::ExRiccatiFactor"); + } + } else + db = m_copy1(d22, db); + + // printf("Vxx[%d]", k); m_output(Vxx[k]); + // printf("Rux[%d]", k); m_output(Rux[k]); + + // printf("k = %d, VEC: %d, MAT: %d\n",k,mem_info_numvar(TYPE_VEC,0), + // mem_info_numvar(TYPE_MAT,0)); + } + + // Initial state + if ( _fixed_x0 ) { + m1 = m_copy1(db, m1); + } else { + m1 = m_resize(m1, _nk[0]+cbx[0]->m, _nk[0]+cbx[0]->m); + m1 = m_zero(m1); + m1 = m_move(Vxx[0], 0, 0, _nk[0], _nk[0], m1, 0, 0); + m1 = m_move(cbx[0], 0, 0, cbx[0]->m, _nk[0], m1, _nk[0], 0); + m2 = m_transp(cbx[0], m2); + m1 = m_move(m2, 0, 0, _nk[0], cbx[0]->m, m1, 0, _nk[0]); + m1 = m_move(db, 0, 0, db->m, db->n, m1, _nk[0], _nk[0]); + } + pivot = px_resize(pivot, m1->m); + blocks = px_resize(blocks, m1->m); + m1 = BKPfactor(m1, pivot, blocks); + // do not change m1, pivot, blocks! + +} + +//-------------------------------------------------------------------------- +// Extended Riccati solution: solve routine. +// E. Arnold 10/08/96 +// 02/22/97 _nk, _mk +//-------------------------------------------------------------------------- +void Hqp_IpLQDOCP::ExRiccatiSolve(void) +{ + int k, k1, knm, kn; + + // Backward run for Vx, Ru + + Vx[_kmax] = v_copy1(gx[_kmax], Vx[_kmax]); + cb[_kmax] = v_copy1(a[_kmax], cb[_kmax]); + + for (k = _kmax-1; k >= 0; k--) { + k1 = k+1; + + // printf("k = %d, start\n", k); + // Gx, Gu + if ( !_a_sparse ) + FormGx(k); + else + FormGxSp(k); + + // printf("k = %d, cb\n", k); + // cb = PQ*[a; cb*f] (remove fixed initial states) + v1 = mv_mlt(cbx[k1], f[k], v1); + v1 = v_add(cb[k1], v1, v1); + v2 = v_concat(a[k], v1, v2); + if ( ( k == 0 ) && ( _fixed_x0 ) ) { + v1 = v_resize(v1, v2->dim-_nk[k]); + v1 = v_move(v2, _nk[k], v1->dim, v1, 0); + v2 = v_copy1(v1, v2); + } + cb[k] = vm_mlt(PQ[k], v2, cb[k]); + + if ( S[k]->n == 0 ) { + // printf("k = %d, Ru,Ry\n", k); + // Ru, Ry for unconstrained u + // Ru[k] = CHsolve(CH_Guu[k], Gu, Ru[k]); + Ru[k] = BKPsolve(CH_Guu[k], CH_Guu_p[k], CH_Guu_b[k], Gu, Ru[k]); + Ry[k] = v_resize(Ry[k], 0); + } else { + + // ct + // i = cb[k]->dim-S[k]->n; + ct = v_resize(ct, S[k]->n); + ct = v_move(cb[k], 0, S[k]->n, ct, 0); + + // printf("k = %d, ct\n", k); + // v1 = cttil + v1 = vm_mlt(S[k], Gu, v1); + v2 = mv_mlt(d11[k], v1, v2); + v1 = v_sub(ct, v2, v1); + + // printf("k = %d, Ru\n", k); + // Ru for constrained u + Ru[k] = mv_mlt(S[k], v1, Ru[k]); + + // printf("k = %d, cb\n", k); + // cb + v1 = v_resize(v1, cb[k]->dim-S[k]->n); + v1 = v_move(cb[k], S[k]->n, v1->dim, v1, 0); + cb[k] = v_copy1(v1, cb[k]); + + if ( (int) S[k]->n < _mk[k] ) { + // printf("k = %d, Ru2\n", k); + // Ru for constrained u + v1 = mv_mlt(Guu[k], Ru[k], v1); + v1 = v_sub(Gu, v1, v1); + v2 = mv_mlt(CH_Guu[k], v1, v2); + Ru[k] = v_add(v2, Ru[k], Ru[k]); + } + + // correction of Ru + if ( CD[k]->n > 0 ) + Ru[k] = LUsolve(CD[k], CD_p[k], Ru[k], Ru[k]); + + // printf("k = %d, Ry\n", k); + // Ry for constrained u + v1 = mv_mlt(Guu[k], Ru[k], v1); + v1 = v_sub(Gu, v1, v1); + Ry[k] = vm_mlt(S[k], v1, Ry[k]); + } + + // printf("k = %d, Vx\n", k); + // Vx + v1 = mv_mlt(Gxu[k], Ru[k], v1); + Vx[k] = v_sub(Gx, v1, Vx[k]); + if ( Ry[k]->dim > 0 ) { + v1 = vm_mlt(ctx[k], Ry[k], v1); + Vx[k] = v_sub(Vx[k], v1, Vx[k]); + } + + // printf("k = %d, cb\n", k); + // cb + v1 = vm_mlt(d12[k], Ry[k], v1); + cb[k] = v_sub(cb[k], v1, cb[k]); + } + + // Initial state + x[0] = v_resize(x[0], _nk[0]); + if ( _fixed_x0 ) { + x[0] = v_move(a[0], 0, _nk[0], x[0], 0); + x[0] = sv_mlt(-1.0, x[0], x[0]); + if ( cb[0]->dim > 0 ) { + v1 = v_resize(v1, cb[0]->dim); + v1 = mv_mltadd(cb[0], x[0], cbx[0], 1.0, v1); + v1 = sv_mlt(-1.0, v1, v1); + yb = BKPsolve(m1, pivot, blocks, v1, yb); + } else + yb = v_resize(yb, 0); + } else { + v1 = v_concat(Vx[0], cb[0], v1); + v1 = sv_mlt(-1.0, v1, v1); + v1 = BKPsolve(m1, pivot, blocks, v1, v1); + x[0] = v_move(v1, 0, _nk[0], x[0], 0); + yb = v_resize(yb, v1->dim-_nk[0]); + yb = v_move(v1, _nk[0], v1->dim-_nk[0], yb, 0); + } + + // Forward run for x, u, p + + for (k = 0; k < _kmax; k++) { + + x[k+1] = v_resize(x[k+1], _nk[k+1]); + u[k] = v_resize(u[k], _mk[k]); + p[k] = v_resize(p[k], _nk[k+1]); + + // u = -Rux*x -Ru -Ruyb*yb + v1 = mv_mlt(Rux[k], x[k], v1); + v1 = v_add(v1, Ru[k], v1); + if ( yb->dim > 0 ) { + v2 = mv_mlt(Ruyb[k], yb, v2); + v1 = v_add(v1, v2, v1); + } + u[k] = sv_mlt(-1.0, v1, u[k]); + + // x[k+1] = fx*x+fu*u+f + k1 = k+1; + knm = _nmk[k]; + kn = _nks[k]; + if ( _a_sparse ) + v1 = bspv_mlt(_A_ori, kn, knm, _nk[k+1], x[k], v1); + else + v1 = mv_mlt(fx[k], x[k], v1); + x[k1] = v_add(f[k], v1, x[k1]); + if ( _a_sparse ) + v1 = bspv_mlt(_A_ori, kn, knm+_nk[k], _nk[k+1], u[k], v1); + else + v1 = mv_mlt(fu[k], u[k], v1); + x[k1] = v_add(x[k1], v1, x[k1]); + + // [y; yb] = -(Ryx*x + Ry + Ryyb*yb) + if ( ( Ry[k]->dim+yb->dim > 0 ) || ( ( k == 0 ) && ( _fixed_x0 ) ) ) { + v1 = mv_mlt(Ryx[k], x[k], v1); + v1 = v_add(v1, Ry[k], v1); + if ( yb->dim > 0 ) { + v2 = mv_mlt(Ryyb[k], yb, v2); + v1 = v_add(v1, v2, v1); + } + v1 = sv_mlt(-1.0, v1, v1); + v2 = v_concat(v1, yb, v2); + v1 = mv_mlt(PQ[k], v2, v1); + if ( ( k == 0 ) && ( _fixed_x0 ) ) { + v2 = v_resize(v2, _nk[k]); + v2 = vm_mltadd(Vx[0], yb, cbx[0], 1.0, v2); + v2 = mv_mltadd(v2, x[0], Vxx[0], 1.0, v2); + v2 = sv_mlt(-1.0, v2, v2); + v2 = v_concat(v2, v1, v2); + v1 = v_copy1(v2, v1); + } + y[k] = v_resize(y[k], a[k]->dim); + y[k] = v_move(v1, 0, a[k]->dim, y[k], 0); + yb = v_resize(yb, v1->dim-y[k]->dim); + yb = v_move(v1, a[k]->dim, v1->dim-a[k]->dim, yb, 0); + } + + // p = Vxx*x + Vx + cbx*yb + p[k] = mv_mlt(Vxx[k1], x[k1], p[k]); + p[k] = v_add(p[k], Vx[k1], p[k]); + if ( yb->dim > 0 ) { + v1 = vm_mlt(cbx[k1], yb, v1); + p[k] = v_add(p[k], v1, p[k]); + } + } + + // y[_kmax] = yb + y[_kmax] = v_resize(y[_kmax], yb->dim); + y[_kmax] = v_copy1(yb, y[_kmax]); +} + +//-------------------------------------------------------------------------- +// Extended Riccati solution: factorization routine. +// Diagonal scaled version without inequalities (_wz_tol = HUGE_VAL). +// +// E. Arnold 02/22/97 +//-------------------------------------------------------------------------- +void Hqp_IpLQDOCP::ExRiccatiFactorSc(void) +{ + int k, i, k1, kn, knm; + + // Final stage: set Vxx, cbx, db for _kmax. + + Vxx[_kmax] = m_resize(Vxx[_kmax], _nk[_kmax], _nk[_kmax]); + symsp_extract_mat(_Q_ori, _nmk[_kmax], Vxx[_kmax]); + m1 = m_resize(m1, _nk[_kmax], _nk[_kmax]); + symsp_extract_mat(_CTC, _nmk[_kmax], m1); + Vxx[_kmax] = m_add(Vxx[_kmax], m1, Vxx[_kmax]); + + Formax(_kmax); + cbx[_kmax] = m_copy1(ax, cbx[_kmax]); + + // Backward run: calculate Vxx, Rux, Ryx for k=_kmax-1, ... ,0. + + for (k = _kmax-1; k >= 0; k--) { + k1 = k+1; + kn = _nks[k]; + knm = _nmk[k]; + + // Gxx, Gxu, Guu + if ( !_a_sparse ) + FormGxx(k); + else + FormGxxSp(k); + + // printf("vor Formax\n"); + // ax, au, yny + Formax(k); + + if ( cbx[k1]->m + au->m ) { + // m2 = cbu + // printf("vor cbu\n"); + if ( _a_sparse ) + m1 = mbsptr_mlt(cbx[k1], _AT, kn, knm+_nk[k], _mk[k], m1); + else + m1 = m_mlt(cbx[k1], fu[k], m1); + m2 = m_concatc(au, m1, m2); + + // Generalized elimination + if ( (MAT *)Z == MNULL ) + Z = m_resize(Z, 1, 1); // Z must be allocated for GE_QP()! + GE_QP(m2, S[k], Z, PQ[k], _ge_tol); + + // cbx + if ( _a_sparse ) + m1 = mbsptr_mlt(cbx[k1], _AT, kn, knm, _nk[k], m1); + else + m1 = m_mlt(cbx[k1], fx[k], m1); + m2 = m_concatc(ax, m1, m2); + cbx[k] = mtrm_mlt(PQ[k], m2, cbx[k]); + } else { + S[k] = m_resize(S[k], _mk[k], 0); + Z = m_resize(Z, _mk[k], 0); + PQ[k] = m_resize(PQ[k], 0, 0); + cbx[k] = m_resize(cbx[k], 0, _nk[k]); + } + + if ( S[k]->n == 0 ) { + + // CH_Guu for unconstrained u: CH_Guu is CHfactor! + CH_Guu[k] = m_copy1(Guu[k], CH_Guu[k]); + + // diagonal scaling + sc[k] = v_diag(CH_Guu[k], sc[k]); + for ( i = 0; i < (int) sc[k]->dim; i++ ) + if ( v_entry(sc[k], i) > 1.0 ) + v_set_val(sc[k], i, 1.0/sqrt(v_entry(sc[k], i))); + else + v_set_val(sc[k], i, 1.0); + CH_Guu[k] = dm_mlt(CH_Guu[k], sc[k], CH_Guu[k]); + CH_Guu[k] = md_mlt(CH_Guu[k], sc[k], CH_Guu[k]); + // printf("CH_Guu[%d]: ", k); m_output(CH_Guu[k]); + // CH_Guu[k] = CHfactor(CH_Guu[k]); + CH_Guu_p[k] = px_resize(CH_Guu_p[k], CH_Guu[k]->m); + CH_Guu_b[k] = px_resize(CH_Guu_b[k], CH_Guu[k]->m); + CH_Guu[k] = BKPfactor(CH_Guu[k], CH_Guu_p[k], CH_Guu_b[k]); + + // Rux, Ryx, Ruyb, Ryyb, ctx for unconstrained u + // Rux[k] = CHsolveMT(CH_Guu[k], Gxu[k], Rux[k]); + // printf("vor Rux\n"); + m1 = md_mlt(Gxu[k], sc[k], m1); + // m1 = m_copy1(Gxu[k], m1); + Rux[k] = BKPsolveMT(CH_Guu[k], CH_Guu_p[k], CH_Guu_b[k], m1, Rux[k]); + Rux[k] = dm_mlt(Rux[k], sc[k], Rux[k]); + Ryx[k] = m_resize(Ryx[k], 0, _nk[k]); + ctx[k] = m_resize(ctx[k], 0, _nk[k]); + } else { + + // ctx + ctx[k] = m_resize(ctx[k], S[k]->n, _nk[k]); + ctx[k] = m_move(cbx[k], 0, 0, S[k]->n, _nk[k], ctx[k], 0, 0); + + // Rux, m2 = cttilx + // m1 = mmtr_mlt(d11[k], S[k], m1); + // m2 = mmtr_mlt(m1, Gxu[k], m2); + // m2 = m_sub(ctx[k], m2, m2); + Rux[k] = m_mlt(S[k], ctx[k], Rux[k]); + // Ruyb[k] = m_mlt(S[k], d12[k], Ruyb[k]); + + // cbx + // i = cbx[k]->m-S[k]->n; + m1 = m_resize(m1, cbx[k]->m-S[k]->n, _nk[k]); + m1 = m_move(cbx[k], S[k]->n, 0, m1->m, _nk[k], m1, 0, 0); + cbx[k] = m_copy1(m1, cbx[k]); + + if ( (int) S[k]->n < _mk[k] ) { + + // CH_Guu for constrained u + m1 = m_mlt(Guu[k], Z, m1); + CH_Guu[k] = mtrm_mlt(Z, m1, CH_Guu[k]); + // diagonal scaling + sc[k] = v_diag(CH_Guu[k], sc[k]); + for ( i = 0; i < (int) sc[k]->dim; i++ ) + if ( v_entry(sc[k], i) > 1.0 ) + v_set_val(sc[k], i, 1.0/sqrt(v_entry(sc[k], i))); + else + v_set_val(sc[k], i, 1.0); + CH_Guu[k] = dm_mlt(CH_Guu[k], sc[k], CH_Guu[k]); + CH_Guu[k] = md_mlt(CH_Guu[k], sc[k], CH_Guu[k]); + Z = md_mlt(Z, sc[k], Z); + // CH_Guu[k] = CHfactor(CH_Guu[k]); + // m2 = CHsolveMT(CH_Guu[k], Z, m2); + pivot = px_resize(pivot, CH_Guu[k]->m); + blocks = px_resize(blocks, CH_Guu[k]->m); + CH_Guu[k] = BKPfactor(CH_Guu[k], pivot, blocks); + m2 = BKPsolveMT(CH_Guu[k], pivot, blocks, Z, m2); + CH_Guu[k] = m_mlt(Z, m2, CH_Guu[k]); + + // Rux for constrained u + m1 = m_mlt(Guu[k], Rux[k], m1); + m2 = m_transp(Gxu[k], m2); + m1 = m_sub(m2, m1, m1); + m2 = m_mlt(CH_Guu[k], m1, m2); + Rux[k] = m_add(m2, Rux[k], Rux[k]); + } + + // Ryx + m1 = m_transp(Gxu[k], m1); + m2 = m_mlt(Guu[k], Rux[k], m2); + m1 = m_sub(m1, m2, m1); + Ryx[k] = mtrm_mlt(S[k], m1, Ryx[k]); + } + + // Vxx + m1 = m_mlt(Gxu[k], Rux[k], m1); + Vxx[k] = m_sub(Gxx, m1, Vxx[k]); + if (Ryx[k]->m > 0) { + m1 = mtrm_mlt(ctx[k], Ryx[k], m1); + Vxx[k] = m_sub(Vxx[k], m1, Vxx[k]); + } + + // check for symmetry of Vxx + // printf("vor rel_symm \n"); + if ( rel_symm(Vxx[k]) > 1e-8 ) { + // printf("symmetry check Vxx[%d]: %g\n", k, rel_symm(Vxx[k])); + if ( _logging && rel_symm(Vxx[k]) > 1e-3 ) { + fprintf(stderr, + "LQDOCP: symmetry check Vxx[%d]: %g\n", k, rel_symm(Vxx[k])); + // m_output(Vxx[k]); + // dump(); + // error(E_POSDEF,"ExRiccatiFactor"); + } + } + // printf("vor m_symm \n"); + Vxx[k] = m_symm(Vxx[k], Vxx[k]); + + // printf("Vxx[%d]", k); m_output(Vxx[k]); + // printf("Rux[%d]", k); m_output(Rux[k]); + + // printf("k = %d, VEC: %d, MAT: %d\n",k,mem_info_numvar(TYPE_VEC,0), + // mem_info_numvar(TYPE_MAT,0)); + + } + + // Initial state + if ( _fixed_x0 ) { + // m1 = m_copy1(db, m1); + m1 = m_resize(m1, 0, 0); + } else { + m1 = m_resize(m1, _nk[0]+cbx[0]->m, _nk[0]+cbx[0]->m); + m1 = m_zero(m1); + m1 = m_move(Vxx[0], 0, 0, _nk[0], _nk[0], m1, 0, 0); + m1 = m_move(cbx[0], 0, 0, cbx[0]->m, _nk[0], m1, _nk[0], 0); + m2 = m_transp(cbx[0], m2); + m1 = m_move(m2, 0, 0, _nk[0], cbx[0]->m, m1, 0, _nk[0]); + // m1 = m_move(db, 0, 0, db->m, db->n, m1, _nk[0], _nk[0]); + } + // diagonal scaling + scx0 = v_diag(m1, scx0); + for ( i = 0; i < (int) scx0->dim; i++ ) + if ( v_entry(scx0, i) > 1.0 ) + v_set_val(scx0, i, 1.0/sqrt(v_entry(scx0, i))); + else + v_set_val(scx0, i, 1.0); + m1 = dm_mlt(m1, scx0, m1); + m1 = md_mlt(m1, scx0, m1); + + pivot = px_resize(pivot, m1->m); + blocks = px_resize(blocks, m1->m); + m1 = BKPfactor(m1, pivot, blocks); + // do not change m1, pivot, blocks! + +} + +//-------------------------------------------------------------------------- +// Extended Riccati solution: solve routine. +// Diagonal scaled version without inequalities (_wz_tol = HUGE_VAL). +// +// E. Arnold 02/22/97 +//-------------------------------------------------------------------------- +void Hqp_IpLQDOCP::ExRiccatiSolveSc(void) +{ + int k, k1, knm, kn; + + // Backward run for Vx, Ru + + Vx[_kmax] = v_copy1(gx[_kmax], Vx[_kmax]); + cb[_kmax] = v_copy1(a[_kmax], cb[_kmax]); + + for (k = _kmax-1; k >= 0; k--) { + k1 = k+1; + + // printf("k = %d, start\n", k); + // Gx, Gu + if ( !_a_sparse ) + FormGx(k); + else + FormGxSp(k); + + // printf("k = %d, cb\n", k); + // cb = PQ*[a; cb*f] (remove fixed initial states) + v1 = mv_mlt(cbx[k1], f[k], v1); + v1 = v_add(cb[k1], v1, v1); + v2 = v_concat(a[k], v1, v2); + if ( ( k == 0 ) && ( _fixed_x0 ) ) { + v1 = v_resize(v1, v2->dim-_nk[k]); + v1 = v_move(v2, _nk[k], v1->dim, v1, 0); + v2 = v_copy1(v1, v2); + } + cb[k] = vm_mlt(PQ[k], v2, cb[k]); + + if ( S[k]->n == 0 ) { + // printf("k = %d, Ru,Ry\n", k); + // Ru, Ry for unconstrained u + // Ru[k] = CHsolve(CH_Guu[k], Gu, Ru[k]); + + v1 = v_star(sc[k], Gu, v1); + Ru[k] = BKPsolve(CH_Guu[k], CH_Guu_p[k], CH_Guu_b[k], v1, Ru[k]); + Ru[k] = v_star(Ru[k], sc[k], Ru[k]); + Ry[k] = v_resize(Ry[k], 0); + } else { + + // ct + // i = cb[k]->dim-S[k]->n; + ct = v_resize(ct, S[k]->n); + ct = v_move(cb[k], 0, S[k]->n, ct, 0); + + // printf("k = %d, ct\n", k); + // v1 = cttil + // v1 = vm_mlt(S[k], Gu, v1); + // v2 = mv_mlt(d11[k], v1, v2); + // v1 = v_sub(ct, v2, v1); + + // printf("k = %d, Ru\n", k); + // Ru for constrained u + Ru[k] = mv_mlt(S[k], ct, Ru[k]); + + // printf("k = %d, cb\n", k); + // cb + v1 = v_resize(v1, cb[k]->dim-S[k]->n); + v1 = v_move(cb[k], S[k]->n, v1->dim, v1, 0); + cb[k] = v_copy1(v1, cb[k]); + + if ( (int) S[k]->n < _mk[k] ) { + // printf("k = %d, Ru2\n", k); + // Ru for constrained u + v1 = mv_mlt(Guu[k], Ru[k], v1); + v1 = v_sub(Gu, v1, v1); + v2 = mv_mlt(CH_Guu[k], v1, v2); + Ru[k] = v_add(v2, Ru[k], Ru[k]); + } + + // printf("k = %d, Ry\n", k); + // Ry for constrained u + v1 = mv_mlt(Guu[k], Ru[k], v1); + v1 = v_sub(Gu, v1, v1); + Ry[k] = vm_mlt(S[k], v1, Ry[k]); + } + + // printf("k = %d, Vx\n", k); + // Vx + v1 = mv_mlt(Gxu[k], Ru[k], v1); + Vx[k] = v_sub(Gx, v1, Vx[k]); + if ( Ry[k]->dim > 0 ) { + v1 = vm_mlt(ctx[k], Ry[k], v1); + Vx[k] = v_sub(Vx[k], v1, Vx[k]); + } + } + + // Initial state + x[0] = v_resize(x[0], _nk[0]); + if ( _fixed_x0 ) { + x[0] = v_move(a[0], 0, _nk[0], x[0], 0); + x[0] = sv_mlt(-1.0, x[0], x[0]); + if ( cb[0]->dim > 0 ) { + v1 = v_resize(v1, cb[0]->dim); + v1 = mv_mltadd(cb[0], x[0], cbx[0], 1.0, v1); + v1 = sv_mlt(-1.0, v1, v1); + v1 = v_star(v1, scx0, v1); + yb = BKPsolve(m1, pivot, blocks, v1, yb); + yb = v_star(yb, scx0, yb); + } else + yb = v_resize(yb, 0); + } else { + v1 = v_concat(Vx[0], cb[0], v1); + v1 = sv_mlt(-1.0, v1, v1); + v1 = v_star(v1, scx0, v1); + v1 = BKPsolve(m1, pivot, blocks, v1, v1); + v1 = v_star(v1, scx0, v1); + x[0] = v_move(v1, 0, _nk[0], x[0], 0); + yb = v_resize(yb, v1->dim-_nk[0]); + yb = v_move(v1, _nk[0], v1->dim-_nk[0], yb, 0); + } + + // Forward run for x, u, p + + for (k = 0; k < _kmax; k++) { + + x[k+1] = v_resize(x[k+1], _nk[k+1]); + u[k] = v_resize(u[k], _mk[k]); + p[k] = v_resize(p[k], _nk[k+1]); + + // u = -Rux*x -Ru + v1 = mv_mlt(Rux[k], x[k], v1); + v1 = v_add(v1, Ru[k], v1); + u[k] = sv_mlt(-1.0, v1, u[k]); + + // x[k+1] = fx*x+fu*u+f + k1 = k+1; + knm = _nmk[k]; + kn = _nks[k]; + if ( _a_sparse ) + v1 = bspv_mlt(_A_ori, kn, knm, _nk[k+1], x[k], v1); + else + v1 = mv_mlt(fx[k], x[k], v1); + x[k1] = v_add(f[k], v1, x[k1]); + if ( _a_sparse ) + v1 = bspv_mlt(_A_ori, kn, knm+_nk[k], _nk[k+1], u[k], v1); + else + v1 = mv_mlt(fu[k], u[k], v1); + x[k1] = v_add(x[k1], v1, x[k1]); + + // [y; yb] = -(Ryx*x + Ry) + if ( ( Ry[k]->dim+yb->dim > 0 ) || ( ( k == 0 ) && ( _fixed_x0 ) ) ) { + v1 = mv_mlt(Ryx[k], x[k], v1); + v1 = v_add(v1, Ry[k], v1); + v1 = sv_mlt(-1.0, v1, v1); + v2 = v_concat(v1, yb, v2); + v1 = mv_mlt(PQ[k], v2, v1); + if ( ( k == 0 ) && ( _fixed_x0 ) ) { + v2 = v_resize(v2, _nk[k]); + v2 = vm_mltadd(Vx[0], yb, cbx[0], 1.0, v2); + v2 = mv_mltadd(v2, x[0], Vxx[0], 1.0, v2); + v2 = sv_mlt(-1.0, v2, v2); + v2 = v_concat(v2, v1, v2); + v1 = v_copy1(v2, v1); + } + y[k] = v_resize(y[k], a[k]->dim); + y[k] = v_move(v1, 0, a[k]->dim, y[k], 0); + yb = v_resize(yb, v1->dim-y[k]->dim); + yb = v_move(v1, a[k]->dim, v1->dim-a[k]->dim, yb, 0); + } + + // p = Vxx*x + Vx + cbx*yb + p[k] = mv_mlt(Vxx[k1], x[k1], p[k]); + p[k] = v_add(p[k], Vx[k1], p[k]); + if ( yb->dim > 0 ) { + v1 = vm_mlt(cbx[k1], yb, v1); + p[k] = v_add(p[k], v1, p[k]); + } + } + + // y[_kmax] = yb + y[_kmax] = v_resize(y[_kmax], yb->dim); + y[_kmax] = v_copy1(yb, y[_kmax]); +} diff --git a/hqp/Hqp_IpLQDOCP.h b/hqp/Hqp_IpLQDOCP.h new file mode 100644 index 0000000..d4477b5 --- /dev/null +++ b/hqp/Hqp_IpLQDOCP.h @@ -0,0 +1,183 @@ +/* + * Hqp_IpLQDOCP.h -- + * - Solution of the Newton step equations for the Interior Point + * algorithm. + * - Extended Riccati method for equality constrained linear-quadratic + * discrete-time optimal control problems. + * + * E. Arnold 09/18/96 + * 03/04/97 iterative improvement in base class + */ + +/* + Copyright (C) 1996--1998 Eckhard Arnold + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_IpLQDOCP_H +#define Hqp_IpLQDOCP_H + +#include "Hqp_IpMatrix.h" +#include "Meschach.h" + +#include "t_mesch.h" +#include "meschext_ea.h" + +//---------- Hqp_IpLQDOCP ---------- + +class Hqp_IpLQDOCP: public Hqp_IpMatrix { + + protected: + + int _kmax; + int _kmax1; + Real _wz_tol; + Real _ge_tol; + int _a_sparse; + int _fixed_x0; + int _logging; + + TVECP x; + TVECP u; + TVECP p; + TVECP gx; + TVECP gu; + TVECP f; + TVECP Ru; + TVECP Vx; + + TMATP fx; + TMATP fu; + TMATP Rux; + TMATP Vxx; + TMATP CH_Guu; + TPERMP CH_Guu_p; + TPERMP CH_Guu_b; + IVECP CH_Guu_nr; + TMATP Gxu; + TMATP Guu; + + MATP m1; + MATP m2; + MATP Gxx; + VECP v1; + VECP v2; + VECP Gx; + VECP Gu; + + TVECP a; + TVECP Ry; + TVECP y; + TVECP cb; + MATP ax; + MATP au; + TMATP PQ; + TMATP Ryx; + TMATP cbx; + TMATP ctx; + TMATP S; + MATP Z; + + PERM *pivot; + PERM *blocks; + VECP ct; + VECP yb; + + IVECP _ra; + IVECP _rc; + IVECP _rak; + IVECP _rck; + IVECP _rcka; + IVECP _rca; + TIVECP _raki; + TIVECP _rcki; + TIVECP _rckai; + + SPMAT *_Q_ori; + SPMAT *_A_ori; + SPMAT *_C_ori; + VECP _Z_ori; + VECP _W_ori; + VECP _WZ_ori; + SPMAT *_CT; + SPMAT *_CTC; + SPMAT *_QCTC; + SPMAT *_AT; + + VECP yny; + MATP db; + TMATP d11; + TMATP d12; + MATP d22; + TMATP Ruyb; + TMATP Ryyb; + + TMATP CD; + TPERMP CD_p; + + // residuum + VECP _res1; + VECP _res2; + VECP _res3; + VECP _res4; + + // different number of variables per stage 02/22/97 + IVECP _nk; + IVECP _mk; + IVECP _nmk; + IVECP _nks; + IVECP _indk; + + // diagonal scaling + VECP scx0; + TVECP sc; + + public: + Hqp_IpLQDOCP(); + ~Hqp_IpLQDOCP(); + + int Get_Dim(const Hqp_Program *); + int Check_Structure(const Hqp_Program *); + void Get_Constr_Dim(const Hqp_Program *); + void resize(); + void free(); + void dump(char *); + void dump() { dump("dump.dat"); } + void init(const Hqp_Program *); + void update(const Hqp_Program *); + void factor(const Hqp_Program *, const VEC *, const VEC *); + void step(const Hqp_Program *, const VEC *, const VEC *, + const VEC *, const VEC *, const VEC *, const VEC *, + VEC *, VEC *, VEC *, VEC *); + + void Residuum(const VEC *, const VEC *, const VEC *, const VEC *, + const VEC *, const VEC *, const VEC *, const VEC *, const int); + + void FormGxx(int); + void FormGxxSp(int); + void FormGx(int); + void FormGxSp(int); + void Formax(int); + void ExRiccatiFactor(void); + void ExRiccatiSolve(void); + void ExRiccatiFactorSc(void); + void ExRiccatiSolveSc(void); + + char *name() {return "LQDOCP";} +}; + +#endif diff --git a/hqp/Hqp_IpMatrix.C b/hqp/Hqp_IpMatrix.C new file mode 100644 index 0000000..1e93c2a --- /dev/null +++ b/hqp/Hqp_IpMatrix.C @@ -0,0 +1,192 @@ +/* + * Hqp_IpMatrix.C -- class definition + * + * rf, 9/14/96 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include "Hqp_IpMatrix.h" +#include "Hqp_Program.h" +#include + +IF_BASE_DEFINE(Hqp_IpMatrix); + +//-------------------------------------------------------------------------- +Hqp_IpMatrix::Hqp_IpMatrix() +{ + _r1 = v_resize(v_get(1), 0); + _r2 = v_resize(v_get(1), 0); + _r3 = v_resize(v_get(1), 0); + _r4 = v_resize(v_get(1), 0); + + _dx = v_resize(v_get(1), 0); + _dy = v_resize(v_get(1), 0); + _dz = v_resize(v_get(1), 0); + _dw = v_resize(v_get(1), 0); + + _eps = 1e-10; + + _ifList.append(new If_Float("mat_eps", &_eps)); +} + +//-------------------------------------------------------------------------- +Hqp_IpMatrix::~Hqp_IpMatrix() +{ + v_free(_r1); + v_free(_r2); + v_free(_r3); + v_free(_r4); + + v_free(_dx); + v_free(_dy); + v_free(_dz); + v_free(_dw); +} + +//-------------------------------------------------------------------------- +Real Hqp_IpMatrix::solve(const Hqp_Program *qp, const VEC *z, const VEC *w, + const VEC *r1, const VEC *r2, const VEC *r3, + const VEC *r4, VEC *dx, VEC *dy, VEC *dz, VEC *dw) +{ + int i; + Real res, res_last; + Real alpha; + + if (_dx->dim != dx->dim) { + v_resize(_dx, dx->dim); + v_resize(_r1, r1->dim); + } + if (_dy->dim != dy->dim) { + v_resize(_dy, dy->dim); + v_resize(_r2, r2->dim); + } + if (_dz->dim != dz->dim) { + v_resize(_dz, dz->dim); + v_resize(_dw, dw->dim); + v_resize(_r3, r3->dim); + v_resize(_r4, r4->dim); + } + + // calculate the solution + step(qp, z, w, r1, r2, r3, r4, dx, dy, dz, dw); + res = residuum(qp, z, w, r1, r2, r3, r4, dx, dy, dz, dw); + //fprintf(stderr, " %g", res); + + // iterative refinement + for (i = 0; i < 5 && res > _eps; i++) { + + res_last = res; + + // recalculate the solution + step(qp, z, w, _r1, _r2, _r3, _r4, _dx, _dy, _dz, _dw); + + alpha = 1.0; + do { + v_mltadd(dx, _dx, alpha, dx); + v_mltadd(dy, _dy, alpha, dy); + v_mltadd(dz, _dz, alpha, dz); + v_mltadd(dw, _dw, alpha, dw); + + res = residuum(qp, z, w, r1, r2, r3, r4, dx, dy, dz, dw); + //fprintf(stderr, " %g", res); + + if (res > res_last) { + v_mltadd(dx, _dx, -alpha, dx); + v_mltadd(dy, _dy, -alpha, dy); + v_mltadd(dz, _dz, -alpha, dz); + v_mltadd(dw, _dw, -alpha, dw); + alpha -= 0.3; + } + } + while (res > res_last && alpha > 0.0); + + if (alpha <= 0.0) { + break; + } + } + //fprintf(stderr, "\n"); + + return res; +} + +//-------------------------------------------------------------------------- +Real Hqp_IpMatrix::residuum(const Hqp_Program *qp, + const VEC *z, const VEC *w, + const VEC *r1, const VEC *r2, const VEC *r3, + const VEC *r4, + VEC *dx, VEC *dy, VEC *dz, VEC *dw) +{ + Real res, res_part; + + if (_dx->dim != dx->dim) { + v_resize(_dx, dx->dim); + v_resize(_r1, r1->dim); + } + if (_dy->dim != dy->dim) { + v_resize(_dy, dy->dim); + v_resize(_r2, r2->dim); + } + if (_dz->dim != dz->dim) { + v_resize(_dz, dz->dim); + v_resize(_dw, dw->dim); + v_resize(_r3, r3->dim); + v_resize(_r4, r4->dim); + } + + sp_mv_symmlt(qp->Q, dx, _r1); + sp_vm_mltadd(_r1, dy, qp->A, -1.0, _r1); + sp_vm_mltadd(_r1, dz, qp->C, -1.0, _r1); + v_add(r1, _r1, _r1); + + sp_mv_mlt(qp->A, dx, _r2); + v_sub(r2, _r2, _r2); + + v_add(v_star(z, dw, _r3), v_star(w, dz, _r4), _r4); + v_sub(r4, _r4, _r4); + + sp_mv_mlt(qp->C, dx, _r3); + v_sub(_r3, dw, _r3); + v_sub(r3, _r3, _r3); + + res = v_norm_inf(_r1); + res_part = v_norm_inf(_r2); + res = max(res, res_part); + res_part = v_norm_inf(_r3); + res = max(res, res_part); + res_part = v_norm_inf(_r4); + res = max(res, res_part); + + return res; +} + +//-------------------------------------------------------------------------- +void Hqp_IpMatrix::step(const Hqp_Program *, const VEC *, const VEC *, + const VEC *r1, const VEC *r2, const VEC *r3, + const VEC *r4, VEC *dx, VEC *dy, VEC *dz, VEC *dw) +{ + v_copy(r1, dx); + v_copy(r2, dy); + v_copy(r3, dz); + v_copy(r4, dw); +} + + +//========================================================================== diff --git a/hqp/Hqp_IpMatrix.h b/hqp/Hqp_IpMatrix.h new file mode 100644 index 0000000..fc44364 --- /dev/null +++ b/hqp/Hqp_IpMatrix.h @@ -0,0 +1,93 @@ +/* + * Hqp_IpMatrix.h -- abstract base class + * - manage the Jacobian matrix of Interior Point algorithms + * rf, 6/1/94 + * + * rf, 9/14/96 + * - extended solve-interface + * + * rf, 3/3/97 + * - introduce iterative refinement of solutions + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_IpMatrix_H +#define Hqp_IpMatrix_H + +#include +#include + +#include "Hqp_impl.h" + +class Hqp_Program; + +IF_BASE_DECLARE(Hqp_IpMatrix); + +class Hqp_IpMatrix { + + protected: + If_List _ifList; + + VEC *_r1; + VEC *_r2; + VEC *_r3; + VEC *_r4; + + VEC *_dx; + VEC *_dy; + VEC *_dz; + VEC *_dw; + + Real _eps; + + public: + Hqp_IpMatrix(); + virtual ~Hqp_IpMatrix(); + + virtual void init(const Hqp_Program *) = 0; + virtual void update(const Hqp_Program *) = 0; + + virtual void factor(const Hqp_Program *, + const VEC *z, const VEC *w) = 0; + + // default solve() implements iterative refinement + virtual Real solve(const Hqp_Program *, + const VEC *z, const VEC *w, + const VEC *r1, const VEC *r2, const VEC *r3, + const VEC *r4, + VEC *dx, VEC *dy, VEC *dz, VEC *dw); + + virtual Real residuum(const Hqp_Program *, + const VEC *z, const VEC *w, + const VEC *r1, const VEC *r2, const VEC *r3, + const VEC *r4, + VEC *dx, VEC *dy, VEC *dz, VEC *dw); + + virtual void step(const Hqp_Program *, + const VEC *z, const VEC *w, + const VEC *r1, const VEC *r2, const VEC *r3, + const VEC *r4, + VEC *dx, VEC *dy, VEC *dz, VEC *dw); + + virtual char *name()=0; +}; + +#endif diff --git a/hqp/Hqp_IpRedBdBKP.C b/hqp/Hqp_IpRedBdBKP.C new file mode 100644 index 0000000..51f9998 --- /dev/null +++ b/hqp/Hqp_IpRedBdBKP.C @@ -0,0 +1,356 @@ +/* + * Hqp_IpRedBdBKP.C -- class definition + * + * rf, 9/9/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +extern "C" { +#include +#include +} +#include "sprcm.h" + +#include + +#include "Hqp_Program.h" +#include "Hqp_IpRedBdBKP.h" + +IF_CLASS_DEFINE("RedBdBKP", Hqp_IpRedBdBKP, Hqp_IpMatrix); + +//-------------------------------------------------------------------------- +Hqp_IpRedBdBKP::Hqp_IpRedBdBKP() +{ + _n = _me = _m = 0; + _sbw = -1; + _CT = SMNULL; + _J = BDNULL; + _J_raw = BDNULL; + _J_fct = BDNULL; + _QP2J = PNULL; + _J2QP = PNULL; + _pivot = PNULL; + _blocks = PNULL; + _z = VNULL; + _w = VNULL; + _zw = VNULL; + _scale = VNULL; + _r12 = VNULL; + _xy = VNULL; + _test = VNULL; + _CTC_degree = IVNULL; + _CTC_neigh_start = IVNULL; + _CTC_neighs = IVNULL; + + _ifList.append(new If_Int("mat_sbw", &_sbw)); +} + +//-------------------------------------------------------------------------- +Hqp_IpRedBdBKP::~Hqp_IpRedBdBKP() +{ + sp_free(_CT); + bd_free(_J); + bd_free(_J_raw); + bd_free(_J_fct); + px_free(_QP2J); + px_free(_J2QP); + px_free(_pivot); + px_free(_blocks); + v_free(_z); + v_free(_w); + v_free(_zw); + v_free(_scale); + v_free(_r12); + v_free(_xy); + v_free(_test); + iv_free(_CTC_degree); + iv_free(_CTC_neigh_start); + iv_free(_CTC_neighs); +} + +//-------------------------------------------------------------------------- +BAND *Hqp_IpRedBdBKP::sub_CTC(const PERM *px, BAND *Q) +// return Q - _CT * diags(_zw) * _CT' +// read: _CT, _zw +// write: _scale +{ + int i, j, j_idx, j_end; + int qi, qj; + SPROW *crow; + Real sum, val; + IVEC neigh_header; + IVEC *neigh = &neigh_header; + int lb; + Real **Qmat; + + neigh_header.max_dim = 0; + + lb = Q->lb; + Qmat = Q->mat->me; + crow = _CT->row; + for (i=0; i<_n; i++, crow++) { + + if (crow->len <= 0) { + // just init scaling + val = Qmat[lb][px->pe[i]]; + _scale->ve[i] = min(1.0, sqrt(-1.0 / val)); + } + else { + + // calculate diagonal entry + sum = sprow_inprod(crow, _zw, crow); + val = Qmat[lb][px->pe[i]] -= sum; + _scale->ve[i] = min(1.0, sqrt(-1.0 / val)); + + // calculate resting entries + neigh->ive = _CTC_neighs->ive + _CTC_neigh_start->ive[i]; + neigh->dim = _CTC_neigh_start->ive[i + 1] - _CTC_neigh_start->ive[i]; + j_end = neigh->dim; + for (j_idx=0; j_idxive[j_idx]; + if (j < i) { + sum = sprow_inprod(crow, _zw, _CT->row + j); + qi = px->pe[i]; + qj = px->pe[j]; + + // substract sum from Qij and Qji + + Qmat[lb+qj-qi][qj] -= sum; + Qmat[lb+qi-qj][qi] -= sum; + } + } + } + } + + return Q; +} + +//-------------------------------------------------------------------------- +void Hqp_IpRedBdBKP::init(const Hqp_Program *qp) +{ + IVEC *degree, *neigh_start, *neighs; + SPMAT *QCTC; + SPROW *r1, *r2; + int i, j; + int dim; + Real sum; + + _n = qp->c->dim; + _me = qp->b->dim; + _m = qp->d->dim; + dim = _n + _me; + + // reallocations + + _pivot = px_resize(_pivot, dim); + _blocks = px_resize(_blocks, dim); + _zw = v_resize(_zw, _m); + _scale = v_resize(_scale, _n); + _r12 = v_resize(_r12, dim); + _xy = v_resize(_xy, dim); + _test = v_resize(_test, dim); + + // store C' for further computations + // analyze structure of C'*C + + _C = qp->C; + _CT = sp_transp(qp->C, _CT); + sp_ones(_CT); + v_ones(_zw); + QCTC = sp_get(_n, _n, 10); + r1 = _CT->row; + for (i=0; i<_n; i++, r1++) { + r2 = r1; + for (j=i; j<_n; j++, r2++) { + sum = sprow_inprod(r1, _zw, r2); + if (sum != 0.0) { + sp_set_val(QCTC, i, j, sum); + if (i != j) + sp_set_val(QCTC, j, i, sum); + } + } + } + _CTC_degree = iv_resize(_CTC_degree, _n); + _CTC_neigh_start = iv_resize(_CTC_neigh_start, _n + 1); + _CTC_neighs = sp_rcm_scan(QCTC, SMNULL, SMNULL, + _CTC_degree, _CTC_neigh_start, _CTC_neighs); + + // initialize structure of reduced qp + + QCTC = sp_add(qp->Q, QCTC, QCTC); + + // determine RCM ordering + + degree = iv_get(dim); + neigh_start = iv_get(dim + 1); + neighs = sp_rcm_scan(QCTC, qp->A, SMNULL, degree, neigh_start, IVNULL); + + _QP2J = sp_rcm_order(degree, neigh_start, neighs, _QP2J); + _sbw = sp_rcm_sbw(neigh_start, neighs, _QP2J); + _J2QP = px_inv(_QP2J, _J2QP); + + iv_free(degree); + iv_free(neigh_start); + iv_free(neighs); + + // allocate Jacobian matrices + + _J = bd_resize(_J, _sbw, _sbw, dim); + _J_raw = bd_resize(_J_raw, _sbw, _sbw, dim); + _J_fct = bd_resize(_J_fct, _sbw, 2 * _sbw, dim); + + sp_free(QCTC); + + // prepare iterations + + update(qp); +} + +//-------------------------------------------------------------------------- +void Hqp_IpRedBdBKP::update(const Hqp_Program *qp) +{ + // prepare _J_raw + m_zero(_J_raw->mat); + sp_into_bd(qp->Q, -1.0, _J_raw, _QP2J, 0, 0); + spT_into_bd(qp->A, 1.0, _J_raw, _QP2J, 0, _n); + sp_into_bd(qp->A, 1.0, _J_raw, _QP2J, _n, 0); + + // update _CT + _C = qp->C; + _CT = sp_transp(qp->C, _CT); +} + +//-------------------------------------------------------------------------- +void Hqp_IpRedBdBKP::factor(const VEC *z, const VEC *w) +{ + assert((int)z->dim == _m && (int)w->dim == _m); + + int i, i_end; + int j, j_end, k, l; + int lb, ub, bw; + Real scale; + Real **Jmat; + int dim = _n+_me; + + // store z and w + _z = v_copy(z, _z); + _w = v_copy(w, _w); + + // copy _J_raw into _J + bd_copy(_J_raw, _J); + + // augment _J + v_slash(w, z, _zw); + + sub_CTC(_QP2J, _J); + + // diagonal scaling + + lb = _J->lb; + ub = _J->ub; + bw = _J->mat->m; + Jmat = _J->mat->me; + j_end = _n; + for (j=0; jve[j]; + k = _QP2J->pe[j]; + i_end = _J_raw->mat->m; // scale k'th col of _J + for (i=0; ilb, _J->ub, dim); // no memory reallocation! + bd_copy(_J, _J_fct); + + // factorization of _J_fct + + bdBKPfactor(_J_fct, _pivot, _blocks); +} + +//-------------------------------------------------------------------------- +Real Hqp_IpRedBdBKP::solve(const VEC *r1, const VEC *r2, const VEC *r3, + const VEC *r4, VEC *dx, VEC *dy, VEC *dz, VEC *dw) +{ + VEC v; + Real residuum; + + assert((int)r1->dim == _n && (int)dx->dim == _n); + assert((int)r2->dim == _me && (int)dy->dim == _me); + assert((int)r3->dim == _m && (int)dz->dim == _m); + assert((int)r4->dim == _m && (int)dw->dim == _m); + + // augment, copy, scale and permutate [r1;r2;r3] into _r12 + // calculate, permutate and scale x + + // augment r1 + // temporary store (W^{-1}r_4 + ZW^{-1}r_3) in dz + v_part(_r12, 0, _n, &v); + v_slash(_w, r4, dw); + v_star(_zw, r3, dz); + v_add(dw, dz, dz); + sp_mv_mlt(_CT, dz, &v); + v_sub(r1, &v, &v); + v_star(&v, _scale, &v); + + v_copy(r2, v_part(_r12, _n, _me, &v)); + + px_vec(_J2QP, _r12, _r12); + + bdBKPsolve(_J_fct, _pivot, _blocks, _r12, _xy); + + bd_mv_mlt(_J, _xy, _test); + v_sub(_r12, _test, _test); + residuum = v_norm2(_test); + + px_vec(_QP2J, _xy, _xy); + + v_star(v_part(_xy, 0, _n, &v), _scale, dx); + v_copy(v_part(_xy, _n, _me, &v), dy); + + sp_vm_mlt(_CT, dx, dw); + v_star(_zw, dw, dw); + v_sub(dz, dw, dz); + + // calculate dw + + sv_mlt(-1.0, r3, dw); + sp_mv_mltadd(dw, dx, _C, 1.0, dw); + // usage of _CT is numerically worse! + //sp_vm_mltadd(dw, dx, _CT, 1.0, dw); + + return residuum; +} + + +//========================================================================== diff --git a/hqp/Hqp_IpRedBdBKP.h b/hqp/Hqp_IpRedBdBKP.h new file mode 100644 index 0000000..618dd45 --- /dev/null +++ b/hqp/Hqp_IpRedBdBKP.h @@ -0,0 +1,76 @@ +/* + * Hqp_IpRedBdBKP.h -- + * - manage the Jacobian matrix of Interior Point algorithms + * - eliminate inequality constraints + * - use band matrix and BKP factorization + * + * rf, 9/9/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_IpRedBdBKP_H +#define Hqp_IpRedBdBKP_H + +#include "Hqp_IpMatrix.h" + +class Hqp_IpRedBdBKP: public Hqp_IpMatrix { + + protected: + int _n, _me, _m; // dimensions + int _sbw; // semi band width of _J + SPMAT *_C; + SPMAT *_CT; + BAND *_J; + BAND *_J_raw; + BAND *_J_fct; + PERM *_QP2J; + PERM *_J2QP; + PERM *_pivot; + PERM *_blocks; + VEC *_z; + VEC *_w; + VEC *_zw; + VEC *_scale; + VEC *_r12; + VEC *_xy; + VEC *_test; + + IVEC *_CTC_degree; + IVEC *_CTC_neigh_start; + IVEC *_CTC_neighs; + + BAND *sub_CTC(const PERM *, BAND *); + + public: + Hqp_IpRedBdBKP(); + ~Hqp_IpRedBdBKP(); + + void init(const Hqp_Program *); + void update(const Hqp_Program *); + + void factor(const VEC *z, const VEC *w); + Real solve(const VEC *r1, const VEC *r2, const VEC *r3, const VEC *r4, + VEC *dx, VEC *dy, VEC *dz, VEC *dw); + + char *name() {return "RedBdBKP";} +}; + +#endif diff --git a/hqp/Hqp_IpRedSpBKP.C b/hqp/Hqp_IpRedSpBKP.C new file mode 100644 index 0000000..7cdf71b --- /dev/null +++ b/hqp/Hqp_IpRedSpBKP.C @@ -0,0 +1,370 @@ +/* + * Hqp_IpRedSpBKP.C -- class definition + * + * rf, 9/13/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +extern "C" { +#include +} + +#include +#include + +#include "sprcm.h" +#include "Hqp_Program.h" +#include "Hqp_IpRedSpBKP.h" + +IF_CLASS_DEFINE("RedSpBKP", Hqp_IpRedSpBKP, Hqp_IpMatrix); + +int sp_size(const SPMAT *A) +{ + if (!A) + return 0; + int i, m = A->m; + int size = sizeof(SPMAT); + + for (i=0; irow[i].maxlen * sizeof(row_elt); + } + + return size; +} + + +//-------------------------------------------------------------------------- +Hqp_IpRedSpBKP::Hqp_IpRedSpBKP() +{ + _n = _me = _m = 0; + _sbw = -1; + _tol = 1.0; + _CT = SMNULL; + _J = SMNULL; + _J_raw = SMNULL; + _QP2J = PNULL; + _J2QP = PNULL; + _pivot = PNULL; + _blocks = PNULL; + _zw = VNULL; + _scale = VNULL; + _r12 = VNULL; + _xy = VNULL; + _CTC_degree = IVNULL; + _CTC_neigh_start = IVNULL; + _CTC_neighs = IVNULL; + + _ifList.append(new If_Int("mat_sbw", &_sbw)); + _ifList.append(new If_Float("mat_tol", &_tol)); +} + +//-------------------------------------------------------------------------- +Hqp_IpRedSpBKP::~Hqp_IpRedSpBKP() +{ + sp_free(_CT); + sp_free(_J); + sp_free(_J_raw); + px_free(_QP2J); + px_free(_J2QP); + px_free(_pivot); + px_free(_blocks); + v_free(_zw); + v_free(_scale); + v_free(_r12); + v_free(_xy); + iv_free(_CTC_degree); + iv_free(_CTC_neigh_start); + iv_free(_CTC_neighs); +} + +//-------------------------------------------------------------------------- +SPMAT *Hqp_IpRedSpBKP::sub_CTC(const PERM *px, SPMAT *Q) +// return Q - _CT * diag(_zw) * _CT' +// read: _CT, _zw +// write: _scale +{ + int i, j, j_idx, j_end; + int qi, qj, qj_idx; + SPROW *crow, *qrow; + Real sum, val; + IVEC neigh_header; + IVEC *neigh = &neigh_header; + + assert(Q->n == Q->m); + assert((int)px->size == Q->m && Q->m >= _n); + + if (!Q->flag_diag) + sp_diag_access(Q); + + neigh_header.max_dim = 0; + + crow = _CT->row; + for (i=0; i<_n; i++, crow++) { + + qrow = Q->row + px->pe[i]; + if (crow->len <= 0) { + val = qrow->elt[qrow->diag].val; + _scale->ve[i] = min(1.0, sqrt(-1.0 / val)); + } + else { + + // calculate diagonal entry + sum = sprow_inprod(crow, _zw, crow); + j_idx = qrow->diag; + val = qrow->elt[j_idx].val -= sum; + _scale->ve[i] = min(1.0, sqrt(-1.0 / val)); + + // calculate resting entries + neigh->ive = _CTC_neighs->ive + _CTC_neigh_start->ive[i]; + neigh->dim = _CTC_neigh_start->ive[i + 1] - _CTC_neigh_start->ive[i]; + j_end = neigh->dim; + for (j_idx = 0; j_idx < j_end; j_idx++) { + j = neigh->ive[j_idx]; + if (j < i) { + sum = sprow_inprod(crow, _zw, _CT->row + j); + qi = px->pe[i]; + qj = px->pe[j]; + + // substract sum from Qij or Qji (entry from upper part only) + + if (qi < qj) { + qrow = Q->row + qi; + qj_idx = sprow_idx(qrow, qj); + if (qj_idx < 0) { + // the structure must already have been allocated in init() + error(E_INTERN, "Hqp_IpRedSpBKP"); + } + else { + qrow->elt[qj_idx].val -= sum; + } + } + else { + qrow = Q->row + qj; + qj_idx = sprow_idx(qrow, qi); + if (qj_idx < 0) { + // the structure must already have been allocated in init() + error(E_INTERN, "Hqp_IpRedSpBKP"); + } + else { + qrow->elt[qj_idx].val -= sum; + } + } + } + } + } + } + + return Q; +} + +//-------------------------------------------------------------------------- +void Hqp_IpRedSpBKP::init(const Hqp_Program *qp) +{ + IVEC *degree, *neigh_start, *neighs; + SPMAT *QCTC; + SPROW *r1, *r2; + int i, j; + int len, dim; + Real sum; + + _n = qp->c->dim; + _me = qp->b->dim; + _m = qp->d->dim; + dim = _n + _me; + + // reallocations + + _pivot = px_resize(_pivot, dim); + _blocks = px_resize(_blocks, dim); + _zw = v_resize(_zw, _m); + _scale = v_resize(_scale, _n); + _r12 = v_resize(_r12, dim); + _xy = v_resize(_xy, dim); + + // store C' for further computations + // analyze structure of C'*C + + _CT = sp_transp(qp->C, _CT); + sp_ones(_CT); + v_ones(_zw); + QCTC = sp_get(_n, _n, 10); + r1 = _CT->row; + for (i=0; i<_n; i++, r1++) { + r2 = r1; + for (j=i; j<_n; j++, r2++) { + sum = sprow_inprod(r1, _zw, r2); + if (sum != 0.0) { + sp_set_val(QCTC, i, j, sum); + if (i != j) + sp_set_val(QCTC, j, i, sum); + } + } + } + _CTC_degree = iv_resize(_CTC_degree, _n); + _CTC_neigh_start = iv_resize(_CTC_neigh_start, _n + 1); + _CTC_neighs = sp_rcm_scan(QCTC, SMNULL, SMNULL, + _CTC_degree, _CTC_neigh_start, _CTC_neighs); + + // initialize structure of reduced qp + + QCTC = sp_add(qp->Q, QCTC, QCTC); + + // determine RCM ordering + + degree = iv_get(dim); + neigh_start = iv_get(dim + 1); + neighs = sp_rcm_scan(QCTC, qp->A, SMNULL, degree, neigh_start, IVNULL); + + _QP2J = sp_rcm_order(degree, neigh_start, neighs, _QP2J); + _sbw = sp_rcm_sbw(neigh_start, neighs, _QP2J); + _J2QP = px_inv(_QP2J, _J2QP); + + iv_free(degree); + iv_free(neigh_start); + iv_free(neighs); + + len = 1 + (int)(log((double)dim) / log(2.0)); + sp_free(_J); + sp_free(_J_raw); + _J_raw = sp_get(dim, dim, len); + _J = SMNULL; + + // fill up data (to allocate _J_raw) + sp_into_symsp(QCTC, -1.0, _J_raw, _QP2J, 0, 0); + spT_into_symsp(qp->A, 1.0, _J_raw, _QP2J, 0, _n); + sp_into_symsp(qp->A, 1.0, _J_raw, _QP2J, _n, 0); + + sp_free(QCTC); + + // prepare iterations + + update(qp); +} + +//-------------------------------------------------------------------------- +void Hqp_IpRedSpBKP::update(const Hqp_Program *qp) +{ + // prepare _J_raw + sp_zero(_J_raw); + symsp_into_symsp(qp->Q, -1.0, _J_raw, _QP2J, 0); + spT_into_symsp(qp->A, 1.0, _J_raw, _QP2J, 0, _n); + sp_into_symsp(qp->A, 1.0, _J_raw, _QP2J, _n, 0); + + // update _CT + _CT = sp_transp(qp->C, _CT); +} + +//-------------------------------------------------------------------------- +void Hqp_IpRedSpBKP::factor(const Hqp_Program *qp, + const VEC *z, const VEC *w) +{ + assert((int)z->dim == _m && (int)w->dim == _m); + + int i, i_end; + int j, j_end, k; + Real scale; + SPROW *row; + row_elt *elt; + + // copy _J_raw to _J + _J = sp_copy3(_J_raw, _J); + + // augment _J + v_slash(w, z, _zw); + sub_CTC(_QP2J, _J); + + // diagonal scaling + j_end = _n + _me; + for (j=0; jpe[j]; + row = &(_J->row[k]); + elt = row->elt; + scale = j<_n? _scale->ve[j]: 1.0; + i_end = row->len; + for (i=0; ival *= scale; + k = _J2QP->pe[elt->col]; + if (k < _n) + elt->val *= _scale->ve[k]; + } + } + + // delete zeros + sp_compact(_J, 0.0); + + // factorization of _J + spBKPfactor(_J, _pivot, _tol); +} + +//-------------------------------------------------------------------------- +void Hqp_IpRedSpBKP::step(const Hqp_Program *qp, const VEC *z, const VEC *w, + const VEC *r1, const VEC *r2, const VEC *r3, + const VEC *r4, VEC *dx, VEC *dy, VEC *dz, VEC *dw) +{ + VEC v; + + assert((int)r1->dim == _n && (int)dx->dim == _n); + assert((int)r2->dim == _me && (int)dy->dim == _me); + assert((int)r3->dim == _m && (int)dz->dim == _m); + assert((int)r4->dim == _m && (int)dw->dim == _m); + + // augment, copy, scale and permutate [r1;r2;r3] into _r12 + // calculate, permutate and scale x + + // augment r1 + // temporary store (W^{-1}r_4 + ZW^{-1}r_3) in dz + v_part(_r12, 0, _n, &v); + v_slash(w, r4, dw); + v_star(_zw, r3, dz); + v_add(dw, dz, dz); + sp_mv_mlt(_CT, dz, &v); + v_sub(r1, &v, &v); + v_star(&v, _scale, &v); + + v_copy(r2, v_part(_r12, _n, _me, &v)); + + px_vec(_J2QP, _r12, _r12); + + spBKPsolve(_J, _pivot, _r12, _xy); + + px_vec(_QP2J, _xy, _xy); + + v_star(v_part(_xy, 0, _n, &v), _scale, dx); + v_copy(v_part(_xy, _n, _me, &v), dy); + + sp_vm_mlt(_CT, dx, dw); + v_star(_zw, dw, dw); + v_sub(dz, dw, dz); + + // calculate dw + + sv_mlt(-1.0, r3, dw); + sp_mv_mltadd(dw, dx, qp->C, 1.0, dw); + // usage of _CT is numerically worse! + //sp_vm_mltadd(dw, dx, _CT, 1.0, dw); +} + + +//========================================================================== diff --git a/hqp/Hqp_IpRedSpBKP.h b/hqp/Hqp_IpRedSpBKP.h new file mode 100644 index 0000000..446419b --- /dev/null +++ b/hqp/Hqp_IpRedSpBKP.h @@ -0,0 +1,74 @@ +/* + * Hqp_IpRedSpBKP.h -- + * - manage the Jacobian matrix of Interior Point algorithms + * - eliminate inequality constraints + * - use sparse matrix and BKP factorization + * + * rf, 9/13/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_IpRedSpBKP_H +#define Hqp_IpRedSpBKP_H + +#include "Hqp_IpMatrix.h" + + +class Hqp_IpRedSpBKP: public Hqp_IpMatrix { + + protected: + int _n, _me, _m; // dimensions + int _sbw; + Real _tol; // tolerance for fill-in vs. stability + SPMAT *_CT; + SPMAT *_J; + SPMAT *_J_raw; + PERM *_QP2J; + PERM *_J2QP; + PERM *_pivot; + PERM *_blocks; + VEC *_zw; + VEC *_scale; + VEC *_r12; + VEC *_xy; + + IVEC *_CTC_degree; + IVEC *_CTC_neigh_start; + IVEC *_CTC_neighs; + + SPMAT *sub_CTC(const PERM *, SPMAT *); + + public: + Hqp_IpRedSpBKP(); + ~Hqp_IpRedSpBKP(); + + void init(const Hqp_Program *); + void update(const Hqp_Program *); + + void factor(const Hqp_Program *, const VEC *z, const VEC *w); + void step(const Hqp_Program *, const VEC *z, const VEC *w, + const VEC *r1, const VEC *r2, const VEC *r3, const VEC *r4, + VEC *dx, VEC *dy, VEC *dz, VEC *dw); + + char *name() {return "RedSpBKP";} +}; + +#endif diff --git a/hqp/Hqp_IpSpBKP.C b/hqp/Hqp_IpSpBKP.C new file mode 100644 index 0000000..a5eec13 --- /dev/null +++ b/hqp/Hqp_IpSpBKP.C @@ -0,0 +1,220 @@ +/* + * Hqp_IpSpBKP.C -- class definition + * + * rf, 10/12/95 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +extern "C" { +#include +} +#include "sprcm.h" + +#include +#include + +#include "Hqp_Program.h" +#include "Hqp_IpSpBKP.h" + +IF_CLASS_DEFINE("SpBKP", Hqp_IpSpBKP, Hqp_IpMatrix); + +//-------------------------------------------------------------------------- +Hqp_IpSpBKP::Hqp_IpSpBKP() +{ + _n = _me = _m = 0; + _sbw = -1; + _tol = 1.0; + _J = SMNULL; + _J_raw = SMNULL; + _QP2J = PNULL; + _J2QP = PNULL; + _pivot = PNULL; + _scale = VNULL; + _r123 = VNULL; + _xyz = VNULL; + + _ifList.append(new If_Int("mat_sbw", &_sbw)); + _ifList.append(new If_Float("mat_tol", &_tol)); +} + +//-------------------------------------------------------------------------- +Hqp_IpSpBKP::~Hqp_IpSpBKP() +{ + sp_free(_J); + sp_free(_J_raw); + px_free(_QP2J); + px_free(_J2QP); + px_free(_pivot); + v_free(_scale); + v_free(_r123); + v_free(_xyz); +} + +//-------------------------------------------------------------------------- +void Hqp_IpSpBKP::init(const Hqp_Program *qp) +{ + int dim; + IVEC *degree, *neigh_start, *neighs; + + _n = qp->c->dim; + _me = qp->b->dim; + _m = qp->d->dim; + dim = _n + _me + _m; + + // determine RCM ordering + + degree = iv_get(dim); + neigh_start = iv_get(dim + 1); + neighs = sp_rcm_scan(qp->Q, qp->A, qp->C, degree, neigh_start, IVNULL); + + _QP2J = sp_rcm_order(degree, neigh_start, neighs, _QP2J); + _sbw = sp_rcm_sbw(neigh_start, neighs, _QP2J); + _J2QP = px_inv(_QP2J, _J2QP); + + iv_free(degree); + iv_free(neigh_start); + iv_free(neighs); + + // allocate memory + + sp_free(_J); + sp_free(_J_raw); + _J_raw = sp_get(dim, dim, 1 + (int)(log((double)dim) / log(2.0))); + _J = SMNULL; + _pivot = px_resize(_pivot, dim); + _scale = v_resize(_scale, _m); + _r123 = v_resize(_r123, dim); + _xyz = v_resize(_xyz, dim); + + // fill up data + + update(qp); +} + +//-------------------------------------------------------------------------- +void Hqp_IpSpBKP::update(const Hqp_Program *qp) +{ + int i, i_dst; + int dim = _n+_me+_m; + + sp_zero(_J_raw); + symsp_into_symsp(qp->Q, -1.0, _J_raw, _QP2J, 0); + spT_into_symsp(qp->A, 1.0, _J_raw, _QP2J, 0, _n); + spT_into_symsp(qp->C, 1.0, _J_raw, _QP2J, 0, _n+_me); + sp_into_symsp(qp->A, 1.0, _J_raw, _QP2J, _n, 0); + sp_into_symsp(qp->C, 1.0, _J_raw, _QP2J, _n+_me, 0); + + for (i=_n+_me; ipe[i]; + sp_set_val(_J_raw, i_dst, i_dst, 1.0); + } + + // delete zeros + sp_compact(_J_raw, 0.0); +} + +//-------------------------------------------------------------------------- +void Hqp_IpSpBKP::factor(const Hqp_Program *, const VEC *z, const VEC *w) +{ + assert((int)z->dim == _m && (int)w->dim == _m); + + int i, i_end; + int j, j_end, k; + int n_me = _n + _me; + Real wz; + SPROW *row; + row_elt *elt; + + // copy _J_raw to _J + _J = sp_copy3(_J_raw, _J); + + // insert slacks + j_end = _m; + for (j = 0; j < j_end; j++) { + wz = w->ve[j] / z->ve[j]; + k = _QP2J->pe[n_me + j]; + sp_set_val(_J, k, k, wz); // insert diagonal entry + _scale->ve[j] = min(1.0, sqrt(1.0 / wz)); + } + + // diagonal scaling + j_end = _n + _me + _m; + for (j=0; jpe[j]; + row = &(_J->row[k]); + elt = row->elt; + wz = (j >= n_me)? _scale->ve[j - n_me]: 1.0; + i_end = row->len; + for (i=0; ival *= wz; + k = _J2QP->pe[elt->col]; + if (k >= n_me) + elt->val *= _scale->ve[k - n_me]; + } + } + + // factorization of _J + spBKPfactor(_J, _pivot, _tol); +} + +//-------------------------------------------------------------------------- +void Hqp_IpSpBKP::step(const Hqp_Program *qp, const VEC *z, const VEC *w, + const VEC *r1, const VEC *r2, const VEC *r3, + const VEC *r4, VEC *dx, VEC *dy, VEC *dz, VEC *dw) +{ + VEC v; + + assert((int)r1->dim == _n && (int)dx->dim == _n); + assert((int)r2->dim == _me && (int)dy->dim == _me); + assert((int)r3->dim == _m && (int)dz->dim == _m); + assert((int)r4->dim == _m && (int)dw->dim == _m); + + // copy, scale and permutate [r1;r2;r3] into _r123 + // calculate, permutate and scale x + + v_copy(r1, v_part(_r123, 0, _n, &v)); + v_copy(r2, v_part(_r123, _n, _me, &v)); + v_part(_r123, _n+_me, _m, &v); + v_slash(z, r4, &v); + v_add(&v, r3, &v); + v_star(&v, _scale, &v); + + px_vec(_J2QP, _r123, _r123); + + spBKPsolve(_J, _pivot, _r123, _xyz); + + px_vec(_QP2J, _xyz, _xyz); + + v_copy(v_part(_xyz, 0, _n, &v), dx); + v_copy(v_part(_xyz, _n, _me, &v), dy); + v_star(v_part(_xyz, _n+_me, _m, &v), _scale, dz); + + // calculate dw + + sv_mlt(-1.0, r3, dw); + sp_mv_mltadd(dw, dx, qp->C, 1.0, dw); +} + + +//========================================================================== diff --git a/hqp/Hqp_IpSpBKP.h b/hqp/Hqp_IpSpBKP.h new file mode 100644 index 0000000..a7e6194 --- /dev/null +++ b/hqp/Hqp_IpSpBKP.h @@ -0,0 +1,64 @@ +/* + * Hqp_IpSpBKP.h -- + * - manage the Jacobian matrix of Interior Point algorithms + * - use sparse matrix and symmetric BKP factorization + * + * rf, 10/12/95 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_IpSpBKP_H +#define Hqp_IpSpBKP_H + +#include "Hqp_IpMatrix.h" + + +class Hqp_IpSpBKP: public Hqp_IpMatrix { + + protected: + int _n, _me, _m; // dimensions + int _sbw; // semi band width of _J + Real _tol; // tolerance for fill-in vs. stability + SPMAT *_J; + SPMAT *_J_raw; + PERM *_QP2J; + PERM *_J2QP; + PERM *_pivot; + VEC *_scale; + VEC *_r123; + VEC *_xyz; + + public: + Hqp_IpSpBKP(); + ~Hqp_IpSpBKP(); + + void init(const Hqp_Program *); + void update(const Hqp_Program *); + + void factor(const Hqp_Program *, const VEC *z, const VEC *w); + void step(const Hqp_Program *, const VEC *z, const VEC *w, + const VEC *r1, const VEC *r2, const VEC *r3, const VEC *r4, + VEC *dx, VEC *dy, VEC *dz, VEC *dw); + + char *name() {return "SpBKP";} +}; + +#endif diff --git a/hqp/Hqp_IpSpIter.C b/hqp/Hqp_IpSpIter.C new file mode 100644 index 0000000..90b2d09 --- /dev/null +++ b/hqp/Hqp_IpSpIter.C @@ -0,0 +1,347 @@ +/* + * Hqp_IpSpIter.C -- class definition + * + * rf, 9/13/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +extern "C" { +#include +#include +} + +#include "Hqp_Program.h" +#include "Hqp_Structure.h" +#include "Hqp_IpSpIter.h" + + +//-------------------------------------------------------------------------- +Hqp_IpSpIter::Hqp_IpSpIter() +{ + _n = _me = _m = 0; + _CT = SMNULL; + _J = SMNULL; + _J_raw = SMNULL; + _J_fct = SMNULL; + _QP2J = PNULL; + _J2QP = PNULL; + _pivot = PNULL; + _blocks = PNULL; + _zw = VNULL; + _scale = VNULL; + _r12 = VNULL; + _xy = VNULL; + _test = VNULL; + _CTC_structure = new Hqp_Structure; + _iter = NULL; +} + +//-------------------------------------------------------------------------- +Hqp_IpSpIter::~Hqp_IpSpIter() +{ + sp_free(_CT); + sp_free(_J); + sp_free(_J_raw); + sp_free(_J_fct); + px_free(_QP2J); + px_free(_J2QP); + px_free(_pivot); + px_free(_blocks); + v_free(_zw); + v_free(_scale); + v_free(_r12); + v_free(_xy); + v_free(_test); + delete _CTC_structure; + iter_free(_iter); +} + +//-------------------------------------------------------------------------- +SPMAT *Hqp_IpSpIter::sub_CTC(const PERM *px, SPMAT *Q) +// return Q - _CT * diags(_zw) * _CT' +// read: _CT, _zw +// write: _scale +{ + int i, j, j_idx, j_end; + int qi, qj, qj_idx; + SPROW *crow, *qrow; + Real sum, val; + const IVEC *neigh; + + assert(Q->n == Q->m); + assert(px->size == Q->m && Q->m >= _n); + + if (!Q->flag_diag) + sp_diag_access(Q); + + crow = _CT->row; + for (i=0; i<_n; i++, crow++) { + + qrow = Q->row + px->pe[i]; + if (crow->len <= 0) { + val = qrow->elt[qrow->diag].val; + _scale->ve[i] = min(1.0, sqrt(-1.0 / val)); + } + else { + + // calculate diagonal entry + sum = sprow_inprod(crow, _zw, crow); + j_idx = qrow->diag; + val = qrow->elt[j_idx].val -= sum; + _scale->ve[i] = min(1.0, sqrt(-1.0 / val)); + + // calculate resting entries + neigh = _CTC_structure->neighbours(i); + j_end = neigh->dim; + for (j_idx=0; j_idxive[j_idx]; + if (j < i) { + sum = sprow_inprod(crow, _zw, _CT->row + j); + qi = px->pe[i]; + qj = px->pe[j]; + + // substract sum from Qij and Qji + + qrow = Q->row + qi; + qj_idx = sprow_idx(qrow, qj); + if (qj_idx < 0) { + error(E_INTERN, "Hqp_IpSpIter"); + } + qrow->elt[qj_idx].val -= sum; + + qrow = Q->row + qj; + qj_idx = sprow_idx(qrow, qi); + if (qj_idx < 0) { + error(E_INTERN, "Hqp_IpSpIter"); + } + qrow->elt[qj_idx].val -= sum; + } + } + } + } + + return Q; +} + +//-------------------------------------------------------------------------- +void Hqp_IpSpIter::init(const Hqp_Program *qp) +{ + Hqp_Structure *sp = new Hqp_Structure; + SPMAT *QCTC; + SPROW *r1, *r2; + int i, j; + int len, dim; + Real sum; + + _n = qp->c->dim; + _me = qp->b->dim; + _m = qp->d->dim; + dim = _n + _me; + + // reallocations + + _pivot = px_resize(_pivot, dim); + _blocks = px_resize(_blocks, dim); + _zw = v_resize(_zw, _m); + _scale = v_resize(_scale, _n); + _r12 = v_resize(_r12, dim); + _xy = v_resize(_xy, dim); + _test = v_resize(_test, dim); + + iter_free(_iter); + _iter = iter_get(dim, dim); + _iter->info = NULL; + v_rand(_xy); + + // store C' for further computations + // analyze structure of C'*C + + _CT = sp_transp(qp->C, _CT); + sp_ones(_CT); + v_ones(_zw); + QCTC = sp_get(_n, _n, 10); + r1 = _CT->row; + for (i=0; i<_n; i++, r1++) { + r2 = r1; + for (j=i; j<_n; j++, r2++) { + sum = sprow_inprod(r1, _zw, r2); + if (sum != 0.0) { + sp_set_val(QCTC, i, j, sum); + if (i != j) + sp_set_val(QCTC, j, i, sum); + } + } + } + _CTC_structure->init_spmat(QCTC); + + // initialize structure of reduced qp + + QCTC = sp_add(qp->Q, QCTC, QCTC); + sp->init_QA(QCTC, qp->A); + sp->order_rcm(); + _QP2J = sp->px_get(_QP2J); + _J2QP = px_inv(_QP2J, _J2QP); + len = 2 * sp->nentries() / dim; + sp_free(_J); + sp_free(_J_raw); + sp_free(_J_fct); + _J_raw = sp_get(dim, dim, len); + _J_fct = SMNULL; + _J = SMNULL; + + // fill up data (to allocate _J_raw) + sp_into_sp(QCTC, -1.0, _J_raw, _QP2J, 0, 0); + spT_into_sp(qp->A, 1.0, _J_raw, _QP2J, 0, _n); + sp_into_sp(qp->A, 1.0, _J_raw, _QP2J, _n, 0); + + delete sp; + sp_free(QCTC); + + // prepare iterations + + update(qp); +} + +//-------------------------------------------------------------------------- +void Hqp_IpSpIter::update(const Hqp_Program *qp) +{ + // prepare _J_raw + sp_zero(_J_raw); + sp_into_sp(qp->Q, -1.0, _J_raw, _QP2J, 0, 0); + spT_into_sp(qp->A, 1.0, _J_raw, _QP2J, 0, _n); + sp_into_sp(qp->A, 1.0, _J_raw, _QP2J, _n, 0); + + // update _CT + _CT = sp_transp(qp->C, _CT); + +} + +//-------------------------------------------------------------------------- +void Hqp_IpSpIter::factor(const VEC *z, const VEC *w) +{ + assert(z->dim == _m && w->dim == _m); + + int i, i_end; + int j, j_end, k; + Real scale; + SPROW *row; + row_elt *elt; + + // copy _J_raw to _J + _J = sp_copy3(_J_raw, _J); + + // augment _J + v_slash(w, z, _zw); + sub_CTC(_QP2J, _J); + + // diagonal scaling + j_end = _n + _me; + for (j=0; jpe[j]; + row = &(_J->row[k]); + elt = row->elt; + scale = j<_n? _scale->ve[j]: 1.0; + i_end = row->len; + for (i=0; ival *= scale; + k = _J2QP->pe[elt->col]; + if (k < _n) + elt->val *= _scale->ve[k]; + } + } + + // incomplete Cholesky factorization + _J_fct = sp_copy3(_J, _J_fct); + spILUfactor(_J_fct, 0.1); + px_ident(_pivot); +} + +//-------------------------------------------------------------------------- +Real Hqp_IpSpIter::solve(const VEC *r1, const VEC *r2, const VEC *r3, + VEC *dx, VEC *dy, VEC *dz) +{ + static VEC v; + Real residuum = 0.0; + + assert(r1->dim == _n && dx->dim == _n); + assert(r2->dim == _me && dy->dim == _me); + assert(r3->dim == _m && dz->dim == _m); + + // augment, copy, scale and permutate [r1;r2;r3] into _r12 + // calculate, permutate and scale x + + // augment r1 + v_part(_r12, 0, _n, &v); + v_star(_zw, r3, dz); + sp_mv_mlt(_CT, dz, &v); + v_sub(r1, &v, &v); + v_star(&v, _scale, &v); + + v_copy(r2, v_part(_r12, _n, _me, &v)); + + px_vec(_J2QP, _r12, _r12); + + iter_Ax(_iter, &sp_mv_mlt, _J); + iter_ATx(_iter, &sp_vm_mlt, _J); + iter_Bx(_iter, &iter_solve, this); + _iter->b = v_copy(_r12, _iter->b); + _iter->eps = 1e-9; + _iter->limit = 10000; + _iter->k = 20; + v_rand(_xy); + iter_mgcr(_iter); + _xy = v_copy(_iter->x, _xy); +// _xy = iter_splsqr(_J, _r12, 1e-9, _xy, 1000, &steps); +//if (_iter->steps >= _iter->limit) + printf("%d\n", _iter->steps); + +// spBKPsolve(_J_fct, _pivot, _r12, _xy); +/* + sp_mv_mlt(_J, _xy, _test); + v_sub(_r12, _test, _test); + residuum = v_norm2(_test); +*/ + px_vec(_QP2J, _xy, _xy); + + v_star(v_part(_xy, 0, _n, &v), _scale, dx); + v_copy(v_part(_xy, _n, _me, &v), dy); + + sp_vm_mlt(_CT, dx, dz); + v_sub(r3, dz, dz); + v_star(_zw, dz, dz); + + return residuum; +} + +VEC *Hqp_IpSpIter::iter_solve(void *cld, VEC *x, VEC *out) +{ + Hqp_IpSpIter *obj = (Hqp_IpSpIter *)cld; + + spLUsolve(obj->_J_fct, PNULL, x, out); + + return out; +} + + +//========================================================================== diff --git a/hqp/Hqp_IpSpIter.h b/hqp/Hqp_IpSpIter.h new file mode 100644 index 0000000..048d040 --- /dev/null +++ b/hqp/Hqp_IpSpIter.h @@ -0,0 +1,78 @@ +/* + * Hqp_IpSpIter.h -- + * - manage the Jacobian matrix of Interior Point algorithms + * - eliminate inequality constraints + * - use sparse matrix and iterative solution + * + * rf, 9/13/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_IpSpIter_H +#define Hqp_IpSpIter_H + +extern "C" { +#include +} + +#include "Hqp_IpMatrix.h" + +class Hqp_Structure; + +class Hqp_IpSpIter: public Hqp_IpMatrix { + + protected: + int _n, _me, _m; // dimensions + SPMAT *_CT; + SPMAT *_J; + SPMAT *_J_raw; + SPMAT *_J_fct; + PERM *_QP2J; + PERM *_J2QP; + PERM *_pivot; + PERM *_blocks; + VEC *_zw; + VEC *_scale; + VEC *_r12; + VEC *_xy; + VEC *_test; + + Hqp_Structure *_CTC_structure; + SPMAT *sub_CTC(const PERM *, SPMAT *); + + ITER *_iter; + static VEC *iter_solve(void *cld, VEC *x, VEC *out); + + public: + Hqp_IpSpIter(); + virtual ~Hqp_IpSpIter(); + + virtual void init(const Hqp_Program *); + virtual void update(const Hqp_Program *); + + virtual void factor(const VEC *z, const VEC *w); + virtual Real solve(const VEC *r1, const VEC *r2, const VEC *r3, + VEC *dx, VEC *dy, VEC *dz); + + char *name() {return "SpIter";} +}; + +#endif diff --git a/hqp/Hqp_IpSpLU.C b/hqp/Hqp_IpSpLU.C new file mode 100644 index 0000000..06d7539 --- /dev/null +++ b/hqp/Hqp_IpSpLU.C @@ -0,0 +1,320 @@ +/* + * Hqp_IpSpLU.C -- class definition + * + * rf, 9/6/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +extern "C" { +#include +} + +#include "Hqp_Program.h" +#include "Hqp_Structure.h" +#include "Hqp_IpSpLU.h" + + +//-------------------------------------------------------------------------- +Hqp_IpSpLU::Hqp_IpSpLU() +{ + _n = _me = _m = 0; + _CT = SMNULL; + _J = SMNULL; + _J_raw = SMNULL; + _J_fct = SMNULL; + _QP2J = PNULL; + _J2QP = PNULL; + _pivot = PNULL; + _blocks = PNULL; + _zw = VNULL; + _scale = VNULL; + _r12 = VNULL; + _xy = VNULL; + _test = VNULL; + _CTC_structure = new Hqp_Structure; +} + +//-------------------------------------------------------------------------- +Hqp_IpSpLU::~Hqp_IpSpLU() +{ + sp_free(_CT); + sp_free(_J); + sp_free(_J_raw); + sp_free(_J_fct); + px_free(_QP2J); + px_free(_J2QP); + px_free(_pivot); + px_free(_blocks); + v_free(_zw); + v_free(_scale); + v_free(_r12); + v_free(_xy); + v_free(_test); + delete _CTC_structure; +} + +//-------------------------------------------------------------------------- +SPMAT *Hqp_IpSpLU::sub_CTC(const PERM *px, SPMAT *Q) +// return Q - _CT * diags(_zw) * _CT' +// read: _CT, _zw +// write: _scale +{ + int i, j, j_idx, j_end; + int qi, qj, qj_idx; + SPROW *crow, *qrow; + Real sum, val; + const IVEC *neigh; + + assert(Q->n == Q->m); + assert(px->size == Q->m && Q->m >= _n); + + if (!Q->flag_diag) + sp_diag_access(Q); + + crow = _CT->row; + for (i=0; i<_n; i++, crow++) { + + qrow = Q->row + px->pe[i]; + if (crow->len <= 0) { + val = qrow->elt[qrow->diag].val; + _scale->ve[i] = min(1.0, sqrt(-1.0 / val)); + } + else { + + // calculate diagonal entry + sum = sprow_inprod(crow, _zw, crow); + j_idx = qrow->diag; + val = qrow->elt[j_idx].val -= sum; + _scale->ve[i] = min(1.0, sqrt(-1.0 / val)); + + // calculate resting entries + neigh = _CTC_structure->neighbours(i); + j_end = neigh->dim; + for (j_idx=0; j_idxive[j_idx]; + if (j < i) { + sum = sprow_inprod(crow, _zw, _CT->row + j); + qi = px->pe[i]; + qj = px->pe[j]; + + // substract sum from Qij and Qji + + qrow = Q->row + qi; + qj_idx = sprow_idx(qrow, qj); + if (qj_idx < 0) { + error(E_INTERN, "Hqp_IpSpLU"); + } + qrow->elt[qj_idx].val -= sum; + + qrow = Q->row + qj; + qj_idx = sprow_idx(qrow, qi); + if (qj_idx < 0) { + error(E_INTERN, "Hqp_IpSpLU"); + } + qrow->elt[qj_idx].val -= sum; + } + } + } + } + + return Q; +} + +//-------------------------------------------------------------------------- +void Hqp_IpSpLU::init(const Hqp_Program *qp) +{ + Hqp_Structure *sp = new Hqp_Structure; + SPMAT *QCTC; + SPROW *r1, *r2; + int i, j; + int len, dim; + Real sum; + + _n = qp->c->dim; + _me = qp->b->dim; + _m = qp->d->dim; + dim = _n + _me; + + // reallocations + + _pivot = px_resize(_pivot, dim); + _blocks = px_resize(_blocks, dim); + _zw = v_resize(_zw, _m); + _scale = v_resize(_scale, _n); + _r12 = v_resize(_r12, dim); + _xy = v_resize(_xy, dim); + _test = v_resize(_test, dim); + + // store C' for further computations + // analyze structure of C'*C + + _CT = sp_transp(qp->C, _CT); + sp_ones(_CT); + v_ones(_zw); + QCTC = sp_get(_n, _n, 10); + r1 = _CT->row; + for (i=0; i<_n; i++, r1++) { + r2 = r1; + for (j=i; j<_n; j++, r2++) { + sum = sprow_inprod(r1, _zw, r2); + if (sum != 0.0) { + sp_set_val(QCTC, i, j, sum); + if (i != j) + sp_set_val(QCTC, j, i, sum); + } + } + } + _CTC_structure->init_spmat(QCTC); + + // initialize structure of reduced qp + + QCTC = sp_add(qp->Q, QCTC, QCTC); + sp->init_QA(QCTC, qp->A); + sp->order_rcm(); + _QP2J = sp->px_get(_QP2J); + _J2QP = px_inv(_QP2J, _J2QP); + len = 2 * sp->nentries() / dim; + sp_free(_J); + sp_free(_J_raw); + sp_free(_J_fct); + _J_raw = sp_get(dim, dim, len); + _J_fct = SMNULL; + _J = SMNULL; + + // fill up data (to allocate _J_raw) + sp_into_sp(QCTC, -1.0, _J_raw, _QP2J, 0, 0); + spT_into_sp(qp->A, 1.0, _J_raw, _QP2J, 0, _n); + sp_into_sp(qp->A, 1.0, _J_raw, _QP2J, _n, 0); + + delete sp; + sp_free(QCTC); + + // prepare iterations + + update(qp); +} + +//-------------------------------------------------------------------------- +void Hqp_IpSpLU::update(const Hqp_Program *qp) +{ + // prepare _J_raw + sp_zero(_J_raw); + sp_into_sp(qp->Q, -1.0, _J_raw, _QP2J, 0, 0); + spT_into_sp(qp->A, 1.0, _J_raw, _QP2J, 0, _n); + sp_into_sp(qp->A, 1.0, _J_raw, _QP2J, _n, 0); + + // update _CT + _CT = sp_transp(qp->C, _CT); +} + +//-------------------------------------------------------------------------- +void Hqp_IpSpLU::factor(const VEC *z, const VEC *w) +{ + assert(z->dim == _m && w->dim == _m); + + int i, i_end; + int j, j_end, k; + Real scale; + SPROW *row; + row_elt *elt; + + // copy _J_raw to _J + _J = sp_copy3(_J_raw, _J); + + // augment _J + v_slash(w, z, _zw); + sub_CTC(_QP2J, _J); + + // diagonal scaling + j_end = _n + _me; + for (j=0; jpe[j]; + row = &(_J->row[k]); + elt = row->elt; + scale = j<_n? _scale->ve[j]: 1.0; + i_end = row->len; + for (i=0; ival *= scale; + k = _J2QP->pe[elt->col]; + if (k < _n) + elt->val *= _scale->ve[k]; + } + } + + // delete zeros + sp_compact(_J, 0.0); + + // copy _J to _J_fct for factorization + _J_fct = sp_copy3(_J, _J_fct); + + // factorization of _J_fct +// spLUfactor2(_J_fct, _pivot); + spLUfactor(_J_fct, _pivot, 0.1); +} + +//-------------------------------------------------------------------------- +Real Hqp_IpSpLU::solve(const VEC *r1, const VEC *r2, const VEC *r3, + VEC *dx, VEC *dy, VEC *dz) +{ + static VEC v; + Real residuum; + + assert(r1->dim == _n && dx->dim == _n); + assert(r2->dim == _me && dy->dim == _me); + assert(r3->dim == _m && dz->dim == _m); + + // augment, copy, scale and permutate [r1;r2;r3] into _r12 + // calculate, permutate and scale x + + // augment r1 + v_part(_r12, 0, _n, &v); + v_star(_zw, r3, dz); + sp_mv_mlt(_CT, dz, &v); + v_sub(r1, &v, &v); + v_star(&v, _scale, &v); + + v_copy(r2, v_part(_r12, _n, _me, &v)); + + px_vec(_J2QP, _r12, _r12); + + spLUsolve(_J_fct, _pivot, _r12, _xy); + + sp_mv_mlt(_J, _xy, _test); + v_sub(_r12, _test, _test); + residuum = v_norm2(_test); + + px_vec(_QP2J, _xy, _xy); + + v_star(v_part(_xy, 0, _n, &v), _scale, dx); + v_copy(v_part(_xy, _n, _me, &v), dy); + + sp_vm_mlt(_CT, dx, dz); + v_sub(r3, dz, dz); + v_star(_zw, dz, dz); + + return residuum; +} + + +//========================================================================== diff --git a/hqp/Hqp_IpSpLU.h b/hqp/Hqp_IpSpLU.h new file mode 100644 index 0000000..0ff8943 --- /dev/null +++ b/hqp/Hqp_IpSpLU.h @@ -0,0 +1,71 @@ +/* + * Hqp_IpSpLU.h -- + * - manage the Jacobian matrix of Interior Point algorithms + * - eliminate inequality constraints + * - use sparse matrix and LU factorization + * + * rf, 9/6/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_IpSpLU_H +#define Hqp_IpSpLU_H + +#include "Hqp_IpMatrix.h" + +class Hqp_Structure; + +class Hqp_IpSpLU: public Hqp_IpMatrix { + + protected: + int _n, _me, _m; // dimensions + SPMAT *_CT; + SPMAT *_J; + SPMAT *_J_raw; + SPMAT *_J_fct; + PERM *_QP2J; + PERM *_J2QP; + PERM *_pivot; + PERM *_blocks; + VEC *_zw; + VEC *_scale; + VEC *_r12; + VEC *_xy; + VEC *_test; + + Hqp_Structure *_CTC_structure; + SPMAT *sub_CTC(const PERM *, SPMAT *); + + public: + Hqp_IpSpLU(); + virtual ~Hqp_IpSpLU(); + + virtual void init(const Hqp_Program *); + virtual void update(const Hqp_Program *); + + virtual void factor(const VEC *z, const VEC *w); + virtual Real solve(const VEC *r1, const VEC *r2, const VEC *r3, + VEC *dx, VEC *dy, VEC *dz); + + char *name() {return "SpLU";} +}; + +#endif diff --git a/hqp/Hqp_IpSpSC.C b/hqp/Hqp_IpSpSC.C new file mode 100644 index 0000000..22c2c4c --- /dev/null +++ b/hqp/Hqp_IpSpSC.C @@ -0,0 +1,421 @@ +/* + * Hqp_IpSpSC.C -- class definition + * + * hl, 96/10/09 + */ + +/* + Copyright (C) 1996--1998 Hartmut Linke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +extern "C" { +#include +} + +extern "C" { +#include +} + +#include +#include + +SPMAT *spLTMsolve(SPMAT *, SPMAT *,SPMAT *); +SPMAT *sp_mmt_mlt(const SPMAT *, SPMAT *); +SPMAT *sp_mmt2_mlt(const SPMAT *, const SPMAT *, SPMAT *); +SPMAT *sp_mmt2_mlt_u(const SPMAT *, const SPMAT *, SPMAT *); +SPMAT *spCHOLfac(SPMAT *); +SPMAT *spMODCHOLfac(SPMAT *, VEC *, double); +VEC *spCHOLsol(SPMAT *, VEC *, VEC *); + +#include "sprcm.h" +#include "Hqp_Program.h" +#include "Hqp_IpSpSC.h" + +IF_CLASS_DEFINE("SpSC", Hqp_IpSpSC, Hqp_IpMatrix); + +/* sp_set_val3 -- sets the (i,j) entry of the sparse matrix A */ +/* don't destroy flag_diag */ +static double sp_set_val3(SPMAT *A, int i, int j, double val) +{ + SPROW *r; + int idx, idx2, new_len; + + if ( A == SMNULL ) + error(E_NULL,"sp_set_val3"); + if ( i < 0 || i >= A->m || j < 0 || j >= A->n ) + error(E_SIZES,"sp_set_val3"); + + r = A->row+i; + idx = sprow_idx(r,j); + /* printf("sp_set_val: idx = %d\n",idx); */ + if ( idx >= 0 ) + { r->elt[idx].val = val; return val; } + /* else */ if ( idx < -1 ) + { + /* Note: this destroys the column & diag access paths */ + /* rf: don't destroy flag_diag */ + A->flag_col = FALSE; + /* shift & insert new value */ + idx = -(idx+2); /* this is the intended insertion index */ + if ( r->len >= r->maxlen ) + { + r->len = r->maxlen; + new_len = max(2*r->maxlen+1,5); + if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,A->row[i].maxlen*sizeof(row_elt), + new_len*sizeof(row_elt)); + } + + r->elt = RENEW(r->elt,new_len,row_elt); + if ( ! r->elt ) /* can't allocate */ + error(E_MEM,"sp_set_val"); + r->maxlen = new_len; + } + for ( idx2 = r->len-1; idx2 >= idx; idx2-- ) + MEM_COPY((char *)(&(r->elt[idx2])), + (char *)(&(r->elt[idx2+1])),sizeof(row_elt)); + /************************************************************ + if ( idx < r->len ) + MEM_COPY((char *)(&(r->elt[idx])),(char *)(&(r->elt[idx+1])), + (r->len-idx)*sizeof(row_elt)); + ************************************************************/ + r->len++; + r->elt[idx].col = j; + if (j == i) + r->diag = j; + else if (j < i) + r->diag++; + return r->elt[idx].val = val; + } + /* else -- idx == -1, error in index/matrix! */ + return 0.0; +} + +//-------------------------------------------------------------------------- +Hqp_IpSpSC::Hqp_IpSpSC() +{ + _n = _me = _m = 0; + _piv_QCVC_flag = 0; + _piv_AQCVCA_flag = 0; + _sbw = -1; + + _macheps = MACHEPS; + + _Q = SMNULL; + _CT = SMNULL; + _AT = SMNULL; + _QCVC = SMNULL; + _QCVCA = SMNULL; + _AQCVC = SMNULL; + _AQCVCA = SMNULL; + _AQCVCA_fac = SMNULL; + + _piv_QCVC = PNULL; + _piv_AQCVCA = PNULL; + + _zw = VNULL; + _v1 = VNULL; + _v2 = VNULL; + _scale = VNULL; + + _CTC_degree = IVNULL; + _CTC_neigh_start = IVNULL; + _CTC_neighs = IVNULL; + + //_ifList.append(new If_Int("mat_sbw", &_sbw)); // not supported + _ifList.append(new If_Float("mat_macheps", &_macheps)); +} + +//-------------------------------------------------------------------------- +Hqp_IpSpSC::~Hqp_IpSpSC() +{ + sp_free(_Q); + sp_free(_CT); + sp_free(_AT); + sp_free(_QCVC); + sp_free(_QCVCA); + sp_free(_AQCVC); + sp_free(_AQCVCA); + sp_free(_AQCVCA_fac); + + px_free(_piv_QCVC); + px_free(_piv_AQCVCA); + + v_free(_zw); + v_free(_v1); + v_free(_v2); + v_free(_scale); + + iv_free(_CTC_degree); + iv_free(_CTC_neigh_start); + iv_free(_CTC_neighs); +} + + +//-------------------------------------------------------------------------- +SPMAT *Hqp_IpSpSC::sub_CTC(const PERM *px, SPMAT *Q) +// return Q - _CT * diag(_zw) * _CT' +// read: _CT, _zw +// write: _scale +{ + int i, j, j_idx, j_end; + int qi, qj, qj_idx; + SPROW *crow, *qrow; + Real sum, val; + IVEC neigh_header; + IVEC *neigh = &neigh_header; + + assert(Q->n == Q->m); + assert((int)px->size == Q->m && Q->m >= _n); + + if (!Q->flag_diag) + sp_diag_access(Q); + + neigh_header.max_dim = 0; + + crow = _CT->row; + for (i=0; i<_n; i++, crow++) { + + qrow = Q->row + px->pe[i]; + if (crow->len <= 0) { + val = qrow->elt[qrow->diag].val; + _scale->ve[i] = min(1.0, sqrt(-1.0 / val)); + } + else { + + // calculate diagonal entry + sum = sprow_inprod(crow, _zw, crow); + j_idx = qrow->diag; + val = qrow->elt[j_idx].val -= sum; + _scale->ve[i] = min(1.0, sqrt(-1.0 / val)); + + // calculate resting entries + neigh->ive = _CTC_neighs->ive + _CTC_neigh_start->ive[i]; + neigh->dim = _CTC_neigh_start->ive[i + 1] - _CTC_neigh_start->ive[i]; + j_end = neigh->dim; + for (j_idx = 0; j_idx < j_end; j_idx++) { + j = neigh->ive[j_idx]; + if (j < i) { + sum = sprow_inprod(crow, _zw, _CT->row + j); + qi = px->pe[i]; + qj = px->pe[j]; + + // substract sum from Qij or Qji (entry from upper part only) + + if (qi < qj) { + qrow = Q->row + qi; + qj_idx = sprow_idx(qrow, qj); + if (qj_idx < 0) { + // the structure must already have been allocated in init() + error(E_INTERN, "Hqp_IpSpSC"); + } + else { + qrow->elt[qj_idx].val -= sum; + } + } + else { + qrow = Q->row + qj; + qj_idx = sprow_idx(qrow, qi); + if (qj_idx < 0) { + // the structure must already have been allocated in init() + error(E_INTERN, "Hqp_IpSpSC"); + } + else { + qrow->elt[qj_idx].val -= sum; + } + } + } + } + } + } + + return Q; +} + +//-------------------------------------------------------------------------- +void Hqp_IpSpSC::init(const Hqp_Program *qp) +{ + + SPROW *r1, *r2; + int i, j; + Real sum; + + _n = qp->c->dim; + _me = qp->b->dim; + _m = qp->d->dim; + + // reallocations + + _piv_QCVC = px_resize(_piv_QCVC, _n); + _piv_AQCVCA = px_resize(_piv_AQCVCA, _me); + + px_ident(_piv_QCVC); + + _zw = v_resize(_zw, _m); + _v1 = v_resize(_v1, _n); + _v2 = v_resize(_v2, _me); + _scale = v_resize(_scale, _n); + + // store C' for further computations + // analyze structure of C'*C + + _CT = sp_get(_n, _m, 10); + _CT = sp_transp(qp->C, _CT); + + sp_ones(_CT); + v_ones(_zw); + + _Q = sp_get(_n, _n, 10); + + r1 = _CT->row; + for (i=0; i<_n; i++, r1++) { + r2 = r1; + for (j=i; j<_n; j++, r2++) { + sum = sprow_inprod(r1, _zw, r2); + if (sum != 0.0) { + sp_set_val(_Q, i, j, sum); + if (i != j) + sp_set_val(_Q, j, i, sum); + } + } + } + + + _CTC_degree = iv_resize(_CTC_degree, _n); + _CTC_neigh_start = iv_resize(_CTC_neigh_start, _n + 1); + _CTC_neighs = sp_rcm_scan(_Q, SMNULL, SMNULL, + _CTC_degree, _CTC_neigh_start, _CTC_neighs); + + // initialize structure of reduced qp + + _QCVC = sp_resize(_QCVC,_n, _n); + _AT = sp_resize(_AT,_n,_me); + _QCVCA = sp_resize(_QCVCA,_n,_me); + _AQCVC = sp_resize(_AQCVC,_me,_n); + _AQCVCA = sp_resize(_AQCVCA,_me,_me); + _AQCVCA_fac = sp_resize(_AQCVCA_fac,_me,_me); + + // prepare iterations + + update(qp); + +} + +//-------------------------------------------------------------------------- +void Hqp_IpSpSC::update(const Hqp_Program *qp) +{ + // prepare QCVC + sp_zero(_Q); + symsp_into_symsp(qp->Q, -1.0, _Q, _piv_QCVC, 0); + + // update _CT + _CT = sp_transp(qp->C, _CT); + _AT = sp_transp(qp->A, _AT); +} + +//-------------------------------------------------------------------------- +void Hqp_IpSpSC::factor(const Hqp_Program *qp, const VEC *z, const VEC *w) +{ + + assert((int)z->dim == _m && (int)w->dim == _m); + + _QCVC = sp_copy3(_Q,_QCVC); + + v_slash(w, z, _zw); + sub_CTC(_piv_QCVC, _QCVC); + sp_smlt(_QCVC, -1.0, _QCVC); + + sp_compact(_QCVC, 0.0); +} + +//-------------------------------------------------------------------------- +Real Hqp_IpSpSC::solve(const Hqp_Program *qp, const VEC *z, const VEC *w, + const VEC *r1, const VEC *r2, const VEC *r3, + const VEC *r4, VEC *dx, VEC *dy, VEC *dz, VEC *dw) +{ + assert((int)r1->dim == _n && (int)dx->dim == _n); + assert((int)r2->dim == _me && (int)dy->dim == _me); + assert((int)r3->dim == _m && (int)dz->dim == _m); + assert((int)r4->dim == _m && (int)dw->dim == _m); + + _v1 = v_resize(_v1, r1->dim); + + // temporary store (W^{-1}r_4 + ZW^{-1}r_3) in dz + v_slash(w, r4, dw); + v_star(_zw, r3, dz); + v_add(dw, dz, dz); + + // temporary store (r1-CT*W^(-1)*(Z*r3+r4)) + sp_mv_mlt(_CT, dz, _v1); + v_sub(r1, _v1, _v1); + v_copy(_v1, dx); + + //spCHOLfac(_QCVC); + spMODCHOLfac(_QCVC, _v1, _macheps); + spCHOLsol(_QCVC, _v1, _v1); + sp_mv_mlt(qp->A, _v1, _v2); + v_add(_v2, r2, _v2); + + _QCVCA = spLTMsolve(_QCVC, _AT, _QCVCA); + _AQCVC = sp_transp(_QCVCA, _AQCVC); + + if(!_piv_AQCVCA_flag) { + _AQCVCA = sp_mmt2_mlt(_AQCVC, _QCVCA, _AQCVCA); + sp_symrcm(_AQCVCA, _piv_AQCVCA); + _piv_AQCVCA_flag = 1; + pxinv_sprows(_piv_AQCVCA, _AQCVCA, _AQCVCA); + pxinv_spcols(_piv_AQCVCA, _AQCVCA, _AQCVCA); + } + else { + _AQCVCA = sp_mmt2_mlt_u(_AQCVC, _QCVCA, _AQCVCA); + pxinv_sprows(_piv_AQCVCA, _AQCVCA, _AQCVCA); + pxinv_spcols(_piv_AQCVCA, _AQCVCA, _AQCVCA); + } + + pxinv_vec(_piv_AQCVCA, _v2, _v2); + + sp_compact(_AQCVCA, 0.0); + _AQCVCA_fac = sp_copy3(_AQCVCA, _AQCVCA_fac); + spMODCHOLfac(_AQCVCA_fac, _v2, _macheps); + // spCHOLfac(_AQCVCA_fac); + spCHOLsol(_AQCVCA_fac, _v2, dy); + + px_vec(_piv_AQCVCA, dy, dy); + + // compute dx + sp_vm_mlt(qp->A, dy, _v1); + v_sub(_v1, dx, _v1); + spCHOLsol(_QCVC, _v1, dx); + + // compute dz + sp_mv_mlt(qp->C, dx, dw); + v_star(_zw, dw, dw); + v_sub(dz, dw, dz); + + // compute dw + sv_mlt(-1.0, r3, dw); + sp_mv_mltadd(dw, dx, qp->C, 1.0, dw); + + return residuum(qp, z, w, r1, r2, r3, r4, dx, dy, dz, dw); +} + + +//========================================================================== diff --git a/hqp/Hqp_IpSpSC.h b/hqp/Hqp_IpSpSC.h new file mode 100644 index 0000000..46d323f --- /dev/null +++ b/hqp/Hqp_IpSpSC.h @@ -0,0 +1,86 @@ +/* + * Hqp_IpSC.h -- + * - manage the Jacobian matrix of Interior Point algorithms + * - eliminate inequality constraints + * - use sparse matrix and solution of schur complement system + * + * hl, 96/10/08 + */ + +/* + Copyright (C) 1996--1998 Hartmut Linke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_IpSpSC_H +#define Hqp_IpSpSC_H + +#include "Hqp_IpMatrix.h" + + +class Hqp_IpSpSC: public Hqp_IpMatrix { + + protected: + int _n, _me, _m; // dimensions + int _sbw; + int _piv_QCVC_flag; + int _piv_AQCVCA_flag; + + double _macheps; + + SPMAT *_Q; + SPMAT *_CT; + SPMAT *_AT; + SPMAT *_QCVC; + SPMAT *_QCVCA; + SPMAT *_AQCVC; + SPMAT *_AQCVCA; + SPMAT *_AQCVCA_fac; + + PERM *_piv_QCVC; + PERM *_piv_AQCVCA; + + VEC *_v1; + VEC *_v2; + VEC *_zw; + VEC *_scale; + VEC *_r12; + VEC *_xy; + + IVEC *_CTC_degree; + IVEC *_CTC_neigh_start; + IVEC *_CTC_neighs; + + SPMAT *sub_CTC(const PERM *, SPMAT *); + + public: + + Hqp_IpSpSC(); + ~Hqp_IpSpSC(); + + void init(const Hqp_Program *); + void update(const Hqp_Program *); + + void factor(const Hqp_Program *, const VEC *z, const VEC *w); + Real solve(const Hqp_Program *, const VEC *z, const VEC *w, + const VEC *r1, const VEC *r2, const VEC *r3, const VEC *r4, + VEC *dx, VEC *dy, VEC *dz, VEC *dw); + + char *name() {return "SpSC";} +}; + +#endif diff --git a/hqp/Hqp_IpsFranke.C b/hqp/Hqp_IpsFranke.C new file mode 100644 index 0000000..77e223d --- /dev/null +++ b/hqp/Hqp_IpsFranke.C @@ -0,0 +1,439 @@ +/* + * Hqp_IpsFranke.C -- class definition + * + * rf, 5/28/94 + * + * References: + * Franke, R.: Anwendung von Interior-Point-Methoden zur Loesung + * zeitdiskreter Optimalsteuerungsprobleme. + * Diploma thesis, TU Ilmenau, Germany, 1994. + * Wright, S.J.: Interior point methods for optimal control of + * discrete time systems JOTA 77(1):161-187, 1993. + * + * rf, 11/5/95: inserted _max_warm_iters + * rf, 2/12/97: treat singular matrix errors + * rf, 4/20/97: treat numerical overflow for _qp->x and _gap + * rf, 8/13/98 + * - rename Hqp_IpSolver to Hqp_IpsFranke + * - make Hqp_IpsFranke an exchangeable interface class + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#include +#include +#include +#include + +#include "Hqp_Program.h" +#include "Hqp_IpRedSpBKP.h" +#include "Hqp_IpsFranke.h" + +IF_CLASS_DEFINE("Franke", Hqp_IpsFranke, Hqp_Solver); + +typedef If_Method If_Cmd; + +//-------------------------------------------------------------------------- +Hqp_IpsFranke::Hqp_IpsFranke() +{ + _n = _me = _m = 0; + + _w = VNULL; + _r1 = VNULL; + _r2 = VNULL; + _r3 = VNULL; + _r4 = VNULL; + _a1 = VNULL; + _a2 = VNULL; + _a3 = VNULL; + _dx = VNULL; + _dy = VNULL; + _dz = VNULL; + _dw = VNULL; + + _matrix = new Hqp_IpRedSpBKP; + + _alpha = 1.0; + _mu0 = 0.0; + _beta = 0.995; + _Ltilde = 0.0; + _fail_iters = 0; + _max_warm_iters = 15; + + _ifList.append(new If_Float("qp_gap", &_gap)); + _ifList.append(new If_Float("qp_alpha", &_alpha)); + _ifList.append(new If_Float("qp_beta", &_beta)); + _ifList.append(new If_Float("qp_rhomin", &_rhomin)); + _ifList.append(new If_Float("qp_mu0", &_mu0)); + _ifList.append(new If_Float("qp_Ltilde", &_Ltilde)); + _ifList.append(new If_Int("qp_fail_iters", &_fail_iters)); + _ifList.append(new If_Int("qp_max_warm_iters", &_max_warm_iters)); + _ifList.append(new IF_MODULE("qp_mat_solver", &_matrix, Hqp_IpMatrix)); + + _ifList.append(new If_Cmd("qp_init", &Hqp_IpsFranke::init, this)); + _ifList.append(new If_Cmd("qp_update", &Hqp_IpsFranke::update, this)); + _ifList.append(new If_Cmd("qp_cold_start", &Hqp_IpsFranke::cold_start, this)); + _ifList.append(new If_Cmd("qp_hot_start", &Hqp_IpsFranke::hot_start, this)); + _ifList.append(new If_Cmd("qp_step", &Hqp_IpsFranke::step, this)); + _ifList.append(new If_Cmd("qp_solve", &Hqp_IpsFranke::solve, this)); +} + +//-------------------------------------------------------------------------- +Hqp_IpsFranke::~Hqp_IpsFranke() +{ + v_free(_w); + v_free(_r1); + v_free(_r2); + v_free(_r3); + v_free(_r4); + v_free(_a1); + v_free(_a2); + v_free(_a3); + v_free(_dx); + v_free(_dy); + v_free(_dz); + v_free(_dw); + delete _matrix; +} + +//-------------------------------------------------------------------------- +int Hqp_IpsFranke::init(IF_CMD_ARGS) +{ + assert(_qp != NULL); + + // allocate matrices and vectors + + _n = _qp->Q->n; + _me = _qp->A->m; + _m = _qp->C->m; + + _y = v_resize(_y, _me); + _z = v_resize(_z, _m); + _w = v_resize(_w, _m); + _r1 = v_resize(_r1, _n); + _r2 = v_resize(_r2, _me); + _r3 = v_resize(_r3, _m); + _r4 = v_resize(_r4, _m); + _a1 = v_resize(_a1, _n); + _a2 = v_resize(_a2, _me); + _a3 = v_resize(_a3, _m); + _dx = v_resize(_dx, _n); + _dy = v_resize(_dy, _me); + _dz = v_resize(_dz, _m); + _dw = v_resize(_dw, _m); + + // fill up internal data + + _matrix->init(_qp); + + return IF_OK; +} + +//-------------------------------------------------------------------------- +int Hqp_IpsFranke::update(IF_CMD_ARGS) +{ + _matrix->update(_qp); + + return IF_OK; +} + +//-------------------------------------------------------------------------- +int Hqp_IpsFranke::cold_start(IF_CMD_ARGS) +{ +// Real Ltilde; + Real min_d; + int i; + + if (_m > 0) { + _rhomin = 1000.0 * _m; + min_d = v_min(_qp->d, NULL); + + if (_mu0 > 0) { + // choose Ltilde according _mu0 + Real mean_d_h; + mean_d_h = 0.5 * v_sum(_qp->d) / (Real) _m; + _Ltilde = - mean_d_h + sqrt(mean_d_h*mean_d_h + (Real)_m*_rhomin*_mu0); + _Ltilde = max(_Ltilde, -min_d); + } + else { + // choose Ltilde according Wright + // (rf, 10/29/95: let Ltilde be greater than 1e2*_m) + Real norm_d; + norm_d = v_norm_inf(_qp->d); +// norm_d = max(1.0, norm_d); + _Ltilde = max(norm_d, -min_d); // actually useless with v_norm_inf() + _Ltilde = max(_Ltilde, 1e2*_m); + } + _zeta = 1.0; + + v_zero(_qp->x); + v_zero(_y); + v_set(_z, _Ltilde / ((Real)_m * _m)); + v_set(_w, _Ltilde); + v_add(_w, _qp->d, _w); + for (i=0; i<_m; i++) + _w->ve[i] += 1e-10; + + v_copy(_qp->c, _a1); + sp_vm_mltadd(_a1, _z, _qp->C, -1.0, _a1); + sv_mlt(1.0/_zeta, _a1, _a1); + + sv_mlt(-1.0/_zeta, _qp->b, _a2); + + v_set(_a3, _Ltilde); + sv_mlt(1.0/_zeta, _a3, _a3); + + _gap = in_prod(_z, _w); + } + + // initialize a program without inequaltiy constraints + else { + v_zero(_qp->x); + v_zero(_y); + v_copy(_qp->c, _a1); + sv_mlt(-1.0, _qp->b, _a2); + _zeta = 1.0; + _gap = 0.0; + } + + _iter = 0; + _alpha = 1.0; + + _hot_started = 0; + _result = Hqp_Infeasible; + + return IF_OK; +} + +//-------------------------------------------------------------------------- +// hot_start: +// - just correct slack vectors a1, a2 and a3 +// +int Hqp_IpsFranke::hot_start(IF_CMD_ARGS) +{ + int i; + + if (_m > 0) { + _zeta = 1.0; + + for (i=0; i<_m; i++) + _w->ve[i] += 1e-10; + + sp_mv_symmlt(_qp->Q, _qp->x, _a1); + v_add(_a1, _qp->c, _a1); + sp_vm_mltadd(_a1, _y, _qp->A, -1.0, _a1); + sp_vm_mltadd(_a1, _z, _qp->C, -1.0, _a1); + + sp_mv_mlt(_qp->A, _qp->x, _a2); + v_add(_a2, _qp->b, _a2); + sv_mlt(-1.0, _a2, _a2); + + sp_mv_mlt(_qp->C, _qp->x, _a3); + v_add(_a3, _qp->d, _a3); + v_sub(_a3, _w, _a3); + sv_mlt(-1.0, _a3, _a3); + + _gap = in_prod(_z, _w) + 1.0; + } + + // initialize a program without inequaltiy constraints + else { + v_zero(_qp->x); + v_zero(_y); + v_copy(_qp->c, _a1); + sv_mlt(-1.0, _qp->b, _a2); + _zeta = 1.0; + _gap = 0.0; + } + + _iter = 0; + _alpha = 1.0; + + _hot_started = 1; + _result = Hqp_Infeasible; + + return IF_OK; +} + +//-------------------------------------------------------------------------- +int Hqp_IpsFranke::step(int, char *[], char **ret) +{ + int i, i_end; + Real mu; + Real val1, val2; + Real *ve1, *ve2; + Real residuum; + + // determine mu according current duality _gap and _zeta + if (_iter == 0) + _alphabar = 1.0; + + val1 = _gap; + if (1.0 / val1 < _rhomin || _alpha < 1.0) { + mu = _alphabar * val1 / _rhomin; // potential reduction + mu += (1.0 - _alphabar) * val1 / (Real)_m; // centering + } else { + mu = val1 * val1; // quadratic converence + } + + // prepare right hand side vectors + + sv_mlt(-_zeta, _a1, _r1); + sv_mlt(-_zeta, _a2, _r2); + sv_mlt(-_zeta, _a3, _r3); + ve1 = _r4->ve; + i_end = _m; + for (i=0; ive[i] * _w->ve[i] - mu; + + // solve the system + + m_catch(E_SING, + // try + _matrix->factor(_qp, _z, _w); + residuum = _matrix->solve(_qp, _z, _w, + _r1, _r2, _r3, _r4, _dx, _dy, _dz, _dw), + // catch(E_SING) + _result = Hqp_Degenerate; + return IF_OK); + + // step size determination (find maximal feasible step) + + val1 = 2.0; + i_end = _m; + ve1 = _dz->ve; + ve2 = _z->ve; + for (i = 0; i < i_end; i++) { + if (*ve1 >= 0.0 && *ve2 < val1 * *ve1) + val1 = *ve2 / *ve1; + ve1++; + ve2++; + } + ve1 = _dw->ve; + ve2 = _w->ve; + for (i = 0; i < i_end; i++) { + if (*ve1 >= 0.0 && *ve2 < val1 * *ve1) + val1 = *ve2 / *ve1; + ve1++; + ve2++; + } + + val1 *= _beta; + _alpha = min(1.0, val1); + + _alphabar = 0.5 * _alphabar + 0.5 * _alpha; + + if (_alphabar == 1.0) { + _rhomin *= 2.0; + } else if (_alphabar < 0.5 && _rhomin > 100.0 * _m) { + _rhomin /= 2.0; + } + + // perform step + + v_mltadd(_qp->x, _dx, -_alpha, _dx); + v_mltadd(_y, _dy, -_alpha, _y); + v_mltadd(_z, _dz, -_alpha, _z); + v_mltadd(_w, _dw, -_alpha, _w); + _zeta *= (1.0 - _alpha); + + _gap = in_prod(_z, _w); + + if (!is_finite(_gap) || !is_finite(v_norm_inf(_dx))) { + _result = Hqp_Degenerate; + return IF_OK; + } + + v_copy(_dx, _qp->x); + _iter ++; + + // return result + // (strange comparisons to filter out NaN) + + if (!(_zeta < _eps)) { + if (_alpha < _eps) + _result = Hqp_Suboptimal; + else + _result = Hqp_Infeasible; + } + //else if (!(_gap < _eps)) + else if (!(_gap < _eps) || !(residuum < _eps)) + _result = Hqp_Feasible; + else { + //fprintf(stderr, "Res %g\n", residuum); + _result = Hqp_Optimal; + } + + return IF_OK; +} + +//-------------------------------------------------------------------------- +int Hqp_IpsFranke::solve(int, char *[], char **ret) +{ + Real gap1 = 0.0; + + _fail_iters = 0; + + do { + do { + step(); + if (_hot_started) { + if (_iter == 1) + gap1 = _gap; + else + if (_gap > gap1) { + //printf("Restarted cold after %d iters (%g)\n", _iter, _gap); + _fail_iters += _iter; + cold_start(); + } + } + + if (_iter + _fail_iters >= _max_iters) break; + if (_hot_started && _iter >= _max_warm_iters) break; + + } while (_result != Hqp_Optimal + && _result != Hqp_Suboptimal && _result != Hqp_Degenerate); + + if (_hot_started && _result != Hqp_Optimal) { + //fprintf(stderr, "Bad hot-start, lost %d iters\n", _iter); + _fail_iters += _iter; + cold_start(); + } else + break; + + } while (1); + + _iter += _fail_iters; + + /* + if (_result == Hqp_Insolvable) { + if (ret) + *ret = hqp_result_strings[_result]; + return IF_ERROR; + } + else + */ + return IF_OK; +} + +//========================================================================== diff --git a/hqp/Hqp_IpsFranke.h b/hqp/Hqp_IpsFranke.h new file mode 100644 index 0000000..de1b549 --- /dev/null +++ b/hqp/Hqp_IpsFranke.h @@ -0,0 +1,97 @@ +/* + * Hqp_IpsFranke.h -- + * - interior point algorithm for solving quadratic programs + * - uses a Hqp_IpMatrix for performing iterates + * rf, 5/28/94 + * + * rf, 9/14/96 + * - extended interface to Hqp_IpMatrix + * + * rf, 8/13/98 + * - rename Hqp_IpSolver to Hqp_IpsFranke + * - make Hqp_IpsFranke an exchangeable interface class + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_IpsFranke_H +#define Hqp_IpsFranke_H + +#include "Hqp_Solver.h" + +class Hqp_Program; +class Hqp_IpMatrix; + +class Hqp_IpsFranke: public Hqp_Solver { + + protected: + int _n, _me, _m; + VEC *_w; // vector of slacks + VEC *_r1; // right hand sides + VEC *_r2; + VEC *_r3; + VEC *_r4; + VEC *_a1; // correcture vectors + VEC *_a2; + VEC *_a3; + VEC *_dx; // modifications for one step + VEC *_dy; + VEC *_dz; + VEC *_dw; + Real _mu0; // used for cold start + Real _Ltilde; + Real _zeta; + Real _alpha; // step width + Real _alphabar; + Real _beta; + Real _rhomin; + Real _gap; // duality gap + + Hqp_IpMatrix *_matrix; + + int _hot_started; // flag + int _fail_iters; // lost iters after a failed warm start + int _max_warm_iters; + + public: + + Hqp_IpsFranke(); + ~Hqp_IpsFranke(); + + // initializing a program + int init(IF_DEF_ARGS); + int update(IF_DEF_ARGS); + + // solving a program + int cold_start(IF_DEF_ARGS); + int hot_start(IF_DEF_ARGS); + int step(IF_DEF_ARGS); + int solve(IF_DEF_ARGS); + + // member access + Real gap() {return _gap;} + Real zeta() {return _zeta;} + + char *name() {return "Franke";} +}; + +#endif + + diff --git a/hqp/Hqp_IpsMehrotra.C b/hqp/Hqp_IpsMehrotra.C new file mode 100644 index 0000000..25eac1e --- /dev/null +++ b/hqp/Hqp_IpsMehrotra.C @@ -0,0 +1,671 @@ +/* + * Hqp_IpMehrotra.C -- class definition + * + * rf, 5/28/94 + * + * rf, 11/5/95: inserted _max_warm_iters + * rf, 2/12/97: treat singular matrix errors + * rf, 4/20/97: treat numerical overflow for _qp->x and _gap + * ea, 5/9/97 + * - Mehrotra´s primal-dual predictor-corrector method for QP problems. + * Mehrotra, S.: On the implementation of a primal-dual interior point + * method. SIAM J. Optimization 2(1992)4, 575-601. + * Wright, S. J.: Primal-dual interior-point methods. + * SIAM, Philadelphia, 1997. + * Czyzyk, J. and Mehrotra, S. and Wright, S. J.: PCx User Guide. + * Technical Report OTC 96/01, + * Optimization Technology Center, 1997. + * + * Problem notation: + * min{ 0.5x'Qx + c'x | Ax+b = 0, Cx+d >= 0 } + * + * _matrix->factor, _matrix->solve solves: + * | -Q A' C' 0 | |dx| |r1| + * | A 0 0 0 | |dy| |r2| + * | C 0 0 -I | |dz| = |r3| + * | 0 0 W Z | |dw| |r4| + * + * 08/25/98 - _logging + * IpSolver -> IpsMehrotra + */ + +/* + Copyright (C) 1994--1998 Eckhard Arnold and Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#include +#include +#include +#include + +#include "Hqp_Program.h" +#include "Hqp_IpRedSpBKP.h" +#include "Hqp_IpsMehrotra.h" + +IF_CLASS_DEFINE("Mehrotra", Hqp_IpsMehrotra, Hqp_Solver); + +typedef If_Method If_Cmd; + +//-------------------------------------------------------------------------- +Hqp_IpsMehrotra::Hqp_IpsMehrotra() +{ + _n = _me = _m = 0; + + _w = VNULL; + _r1 = VNULL; + _r2 = VNULL; + _r3 = VNULL; + _r4 = VNULL; + _dx = VNULL; + _dy = VNULL; + _dz = VNULL; + _dw = VNULL; + _dxa = VNULL; + _dya = VNULL; + _dza = VNULL; + _dwa = VNULL; + _z_hot = VNULL; + _w_hot = VNULL; + _phimin = VNULL; + + _matrix = new Hqp_IpRedSpBKP; + + _alpha = 1.0; + _gammaf = 0.01; + _mu0 = 0.0; // not used + _beta = 0.995; // not used + _fail_iters = 0; + _max_warm_iters = 25; + _logging = 0; + + _ifList.append(new If_Float("qp_gap", &_gap)); + _ifList.append(new If_Float("qp_alpha", &_alpha)); + _ifList.append(new If_Float("qp_beta", &_beta)); + // _ifList.append(new If_Float("qp_rhomin", &_rhomin)); + _ifList.append(new If_Float("qp_mu0", &_mu0)); + // _ifList.append(new If_Float("qp_Ltilde", &_Ltilde)); + _ifList.append(new If_Int("qp_fail_iters", &_fail_iters)); + _ifList.append(new If_Int("qp_max_warm_iters", &_max_warm_iters)); + _ifList.append(new If_Int("qp_logging", &_logging)); + _ifList.append(new IF_MODULE("qp_mat_solver", &_matrix, Hqp_IpMatrix)); + + _ifList.append(new If_Cmd("qp_init", &Hqp_IpsMehrotra::init, this)); + _ifList.append(new If_Cmd("qp_update", &Hqp_IpsMehrotra::update, this)); + _ifList.append(new If_Cmd("qp_cold_start", &Hqp_IpsMehrotra::cold_start, this)); + _ifList.append(new If_Cmd("qp_hot_start", &Hqp_IpsMehrotra::hot_start, this)); + _ifList.append(new If_Cmd("qp_step", &Hqp_IpsMehrotra::step, this)); + _ifList.append(new If_Cmd("qp_solve", &Hqp_IpsMehrotra::solve, this)); +} + +//-------------------------------------------------------------------------- +Hqp_IpsMehrotra::~Hqp_IpsMehrotra() +{ + v_free(_w); + v_free(_r1); + v_free(_r2); + v_free(_r3); + v_free(_r4); + v_free(_dx); + v_free(_dy); + v_free(_dz); + v_free(_dw); + v_free(_dxa); + v_free(_dya); + v_free(_dza); + v_free(_dwa); + v_free(_z_hot); + v_free(_w_hot); + v_free(_phimin); + delete _matrix; +} + +//-------------------------------------------------------------------------- +int Hqp_IpsMehrotra::init(IF_CMD_ARGS) +{ + assert(_qp != NULL); + + // allocate matrices and vectors + + _n = _qp->Q->n; + _me = _qp->A->m; + _m = _qp->C->m; + + _y = v_resize(_y, _me); + _z = v_resize(_z, _m); + _w = v_resize(_w, _m); + _r1 = v_resize(_r1, _n); + _r2 = v_resize(_r2, _me); + _r3 = v_resize(_r3, _m); + _r4 = v_resize(_r4, _m); + _dx = v_resize(_dx, _n); + _dy = v_resize(_dy, _me); + _dz = v_resize(_dz, _m); + _dw = v_resize(_dw, _m); + _dxa = v_resize(_dxa, _n); + _dya = v_resize(_dya, _me); + _dza = v_resize(_dza, _m); + _dwa = v_resize(_dwa, _m); + _z_hot = v_resize(_z_hot, _m); + _w_hot = v_resize(_w_hot, _m); + + // fill up internal data + + _matrix->init(_qp); + + if ( _logging ) + printf("\nHqp_IpsMehrotra::init\n"); + + return IF_OK; +} + +//-------------------------------------------------------------------------- +int Hqp_IpsMehrotra::update(IF_CMD_ARGS) +{ + _matrix->update(_qp); + _phimin = v_resize(_phimin, _max_iters+1); + + if ( _logging ) + printf("\nHqp_IpsMehrotra::update\n"); + + return IF_OK; +} + +//-------------------------------------------------------------------------- +int Hqp_IpsMehrotra::cold_start(IF_CMD_ARGS) +{ + int i, izmin, iwmin, code; + Real delz, delw, residuum; + int c_new = 0; + + if ( _m > 0 ) { + + // ´very cold´ start + // v_zero(_qp->x); + // v_zero(_y); + // v_set(_z, 1.0); + // v_set(_w, 1.0); + + v_set(_z, 1.0); + // v_set(_w, max(v_norm_inf(_qp->d),1e-10)*sp_norm_inf(_qp->Q)/sp_norm_inf(_qp->C)); + v_set(_w, sp_norm_inf(_qp->C)/max(v_norm_inf(_qp->d),1e-10)/ + sp_norm_inf(_qp->Q)); + if ( c_new ) + v_set(_w, 1e10); + +#ifdef m_catch + // init right hand side + + v_copy(_qp->c, _r1); + v_copy(_qp->b, _r2); + sv_mlt(-1.0, _r2, _r2); + v_copy(_qp->d, _r3); + sv_mlt(-1.0, _r3, _r3); + v_star(_z, _w, _r4); + sv_mlt(-1.0, _r4, _r4); + + // factorize and solve + + m_catch(E_SING, + // try + _matrix->factor(_qp, _z, _w); + residuum = + _matrix->solve(_qp, _z, _w, + _r1, _r2, _r3, _r4, _dx, _dy, _dz, _dw), + // catch(E_SING) + if ( _logging ) + printf("\nHqp_Degenerate: vmin(_z) = %g, vmin(_w) = %g\n", + v_min(_z, &izmin), v_min(_w, &iwmin)); + _result = Hqp_Degenerate; + return IF_OK); +#else + // factorize the matrix + + _matrix->factor(_qp, _z, _w); + if ((code = setjmp(restart)) != 0) { + set_err_flag(EF_EXIT); // avoid recursive error calls + if (code == E_SING) { + if ( _logging ) + printf("\nHqp_Degenerate: vmin(_z) = %g, vmin(_w) = %g\n", + v_min(_z, &izmin), v_min(_w, &iwmin)); + _result = Hqp_Degenerate; + return IF_OK; + } + else + error(code, "Hqp_IpsMehrotra::step"); + } + else { +# ifdef DEBUG + set_err_flag(EF_JUMP); +# else + set_err_flag(EF_SILENT); +# endif + } + + // right hand side and solve + + v_copy(_qp->c, _r1); + v_copy(_qp->b, _r2); + sv_mlt(-1.0, _r2, _r2); + v_copy(_qp->d, _r3); + sv_mlt(-1.0, _r3, _r3); + v_star(_z, _w, _r4); + sv_mlt(-1.0, _r4, _r4); + + residuum = _matrix->solve(_qp, _z, _w, + _r1, _r2, _r3, _r4, _dx, _dy, _dz, _dw); +#endif + v_copy(_dx, _qp->x); + v_copy(_dy, _y); + + if ( c_new ) + for ( i = 0; i < _m; i++ ) { + if ( _dw->ve[i] < 0.0 ) { + _dz->ve[i] = -_dw->ve[i]; + _dw->ve[i] = 0.0; + } else + _dz->ve[i] = 0.0; + } + v_add(_dz, _z, _dz); + v_add(_dw, _w, _dw); + delz = v_min(_dz, &izmin); + delw = v_min(_dw, &iwmin); + if ( _logging ) + printf("_dz[%d] = %g, _dw[%d] = %g, ", izmin, delz, iwmin, delw); + if ( v_norm_inf(_dz) == 0.0 ) + v_set(_dz, 1.0e-10); + if ( v_norm_inf(_dw) == 0.0 ) + v_set(_dw, 1.0e-10); + delz = max(-1.5*v_min(_dz, &i), 0.0); + delw = max(-1.5*v_min(_dw, &i), 0.0); + v_set(_r3, delz); + v_add(_r3, _dz, _r3); // 5/5/98 + v_set(_r4, delw); + v_add(_r4, _dw, _r4); // 5/5/98 + _gap = in_prod(_r3, _r4); + delz +=0.5*_gap/(v_sum(_dw)+_m*delw); + delw +=0.5*_gap/(v_sum(_dz)+_m*delz); + for ( i = 0; i < _m; i++ ) { + _z->ve[i] = _dz->ve[i]+delz; + _w->ve[i] = _dw->ve[i]+delw; + } + if ( _logging ) + printf("delz = %g, delw = %g\n", delz, delw); + v_set(_z_hot, 1.0); + v_set(_w_hot, 1.0); + } + + // initialize a program without inequality constraints + else { + v_zero(_qp->x); + v_zero(_y); + } + + _iter = 0; + v_zero(_phimin); + _alpha = 1.0; + + _hot_started = 0; + _result = Hqp_Infeasible; + + if ( _logging ) + printf("\nHqp_IpsMehrotra::cold_start\n"); + + return IF_OK; +} + +//-------------------------------------------------------------------------- +int Hqp_IpsMehrotra::hot_start(IF_CMD_ARGS) +{ + if (_m > 0) { + v_copy(_z_hot, _z); // it is not necessary to correct _z or _w because of + v_copy(_w_hot, _w); // Mehrotra's adaptive step size! + } + + // initialize a program without inequality constraints + else { + v_zero(_qp->x); + v_zero(_y); + } + + _iter = 0; + v_zero(_phimin); + _alpha = 1.0; + + _hot_started = 1; + _result = Hqp_Infeasible; + + if ( _logging ) + printf("\nHqp_IpsMehrotra::hot_start\n"); + + return IF_OK; +} + +//-------------------------------------------------------------------------- +int Hqp_IpsMehrotra::step(int, char *[], char **ret) +{ + int i, izmin, iwmin; + Real residuum, smm, phi, rmu0, pcost, rmu; + Real alfa_aff, mu_aff, mu, sigma, zmin, wmin, fpd, mu_pl; + int code; + + // actual residuum of KKT conditions + + sp_mv_symmlt(_qp->Q, _qp->x, _r1); + pcost = 0.5*in_prod(_qp->x, _r1)+in_prod(_qp->x, _qp->c); + v_add(_r1, _qp->c, _r1); + _gap = in_prod(_qp->x, _r1)+in_prod(_y, _qp->b)+in_prod(_z, _qp->d); + sp_vm_mltadd(_r1, _y, _qp->A, -1.0, _r1); + sp_vm_mltadd(_r1, _z, _qp->C, -1.0, _r1); + sv_mlt(-1.0, _r1, _r1); + + sp_mv_mlt(_qp->A, _qp->x, _r2); + v_add(_r2, _qp->b, _r2); + + sp_mv_mlt(_qp->C, _qp->x, _r3); + v_add(_r3, _qp->d, _r3); + v_sub(_r3, _w, _r3); + + v_star(_z, _w, _r4); + + _test = phi = fabs(_gap)/ + max(1.0, max(v_norm_inf(_qp->c), + max(v_norm_inf(_qp->b), v_norm_inf(_qp->d))))+ + v_norm_inf(_r1)/max(1.0, v_norm_inf(_qp->c))+ + v_norm_inf(_r2)/max(1.0, v_norm_inf(_qp->b))+ + v_norm_inf(_r3)/max(1.0, v_norm_inf(_qp->d)); + mu = in_prod(_z, _w); + + if ( _logging ) { + if ( !( _iter % 15 ) ) + printf("\niter _gap mu phi rmu sigma alfa\n"); + printf("%4d %10.4g %10.4g %10.4g ", _iter, _gap, mu, phi); + } + + // prepare hot start + + // 5/5/98 0.5 ---> 0.3333 + if ( _test > pow(_eps, 0.3333) ) { + // if ( ( _test > pow(_eps, 0.5) ) && ( mu > pow(_eps, 0.5) ) || + // ( _iter == 0 ) ) { + v_copy(_z, _z_hot); + v_copy(_w, _w_hot); + } + + // check for termination + if ( ( v_norm_inf(_r1)/(1.0+v_norm_inf(_qp->c)) <= _eps ) && + ( v_norm_inf(_r2)/(1.0+v_norm_inf(_qp->b)) <= _eps ) && + ( v_norm_inf(_r3)/(1.0+v_norm_inf(_qp->d)) <= _eps ) && + ( fabs(_gap)/(1.0+fabs(pcost)) <= _eps ) ) { + _result = Hqp_Optimal; + return IF_OK; + } + + // _phimin + + if ( _iter == 0 ) + _phimin->ve[0] = phi; + else + _phimin->ve[_iter] = min(_phimin->ve[_iter-1], phi); + + // check for infeasibility + + if ( phi >= max(_eps, 1.0e5*_phimin->ve[_iter]) ) { + // _result = Hqp_Infeasible; // should be "infeasible" + _result = Hqp_Suboptimal; + + if ( _logging ) + printf("\nHqp_Suboptimal: _phi = %g, _phimin[_iter] = %g\n", + phi, _phimin->ve[_iter]); + return IF_OK; + } + + // check for slow convergence + + if ( ( _iter >= 30 ) && + ( _phimin->ve[_iter] >= 0.5*_phimin->ve[_iter-30] ) ) { + _result = Hqp_Suboptimal; // should be "unknown" + + if ( _logging ) + printf("\nHqp_Suboptimal: _phimin[_iter] = %g, _phimin[_iter-30] = %g\n", + _phimin->ve[_iter], _phimin->ve[_iter-30]); + return IF_OK; + } + + // check for blowup in infeasibility-to-duality ratio + + rmu = max(v_norm_inf(_r1), max(v_norm_inf(_r2), v_norm_inf(_r3)))/mu; + if ( _logging ) + printf("%10.4g ", rmu); + if ( _iter == 5 ) + rmu0 = rmu; + else if ( ( _iter > 5 ) && + ( ( v_norm_inf(_r1)/max(1.0, v_norm_inf(_qp->c)) > _eps ) || + ( v_norm_inf(_r2)/max(1.0, v_norm_inf(_qp->b)) > _eps ) || + ( v_norm_inf(_r3)/max(1.0, v_norm_inf(_qp->d)) > _eps ) ) && + ( rmu/rmu0 >= 1.0e6 ) ) { + // printf("\nHqp_Suboptimal: _r1 = %g, _r2 = %g, _r3 = %g, mu = %g, rmu0 = %g\n", + // v_norm_inf(_r1), v_norm_inf(_r2), v_norm_inf(_r3), mu, rmu0); + // 5/5/98 removed check for 'blow up' + // _result = Hqp_Suboptimal; // should be "unknown" + } + +#ifdef m_catch + // factorize the matrix + // and predictor (affine) step calculation + m_catch(E_SING, + // try + _matrix->factor(_qp, _z, _w); + residuum = + _matrix->solve(_qp, _z, _w, + _r1, _r2, _r3, _r4, _dxa, _dya, _dza, _dwa), + // catch(E_SING) + if ( _logging ) + printf("\nHqp_Degenerate: vmin(_z) = %g, vmin(_w) = %g\n", + v_min(_z, &izmin), v_min(_w, &iwmin)); + _result = Hqp_Degenerate; + return IF_OK); + +#else + // factorize the matrix + + _matrix->factor(_qp, _z, _w); + if ((code = setjmp(restart)) != 0) { + set_err_flag(EF_EXIT); // avoid recursive error calls + if (code == E_SING) { + _result = Hqp_Degenerate; + + if ( _logging ) + printf("\nHqp_Degenerate: vmin(_z) = %g, vmin(_w) = %g\n", + v_min(_z, &izmin), v_min(_w, &iwmin)); + return IF_OK; + } + else + error(code, "Hqp_IpsMehrotra::step"); + } + else { +# ifdef DEBUG + set_err_flag(EF_JUMP); +# else + set_err_flag(EF_SILENT); +# endif + } + + // predictor (affine) step calculation + + residuum = _matrix->solve(_qp, _z, _w, + _r1, _r2, _r3, _r4, _dxa, _dya, _dza, _dwa); +#endif + + // predictor step size determination (find maximal feasible step) + + alfa_aff = 1.0; + for ( i = 0; i < _m; i++ ) { + if ( _dza->ve[i] > 0.0 ) + alfa_aff = min(alfa_aff, _z->ve[i]/_dza->ve[i]); + if ( _dwa->ve[i] > 0.0 ) + alfa_aff = min(alfa_aff, _w->ve[i]/_dwa->ve[i]); + } + + alfa_aff = max(0.0, min(alfa_aff, 1.0)); + + // centering parameter sigma + + v_mltadd(_z, _dza, -alfa_aff, _r3); + v_mltadd(_w, _dwa, -alfa_aff, _r4); + mu_aff = in_prod(_r3, _r4); + sigma = pow(mu_aff/mu, 3.0); + + v_star(_r3, _r4, _r4); + smm = sigma*mu/_m; + for (i = 0; i < _m; i++ ) + _r4->ve[i] -= smm; + v_zero(_r1); + v_zero(_r2); + v_zero(_r3); + + // centering and corrector step calculation + + residuum = _matrix->solve(_qp, _z, _w, + _r1, _r2, _r3, _r4, _dx, _dy, _dz, _dw); + v_add(_dx, _dxa, _dx); + v_add(_dy, _dya, _dy); + v_add(_dz, _dza, _dz); + v_add(_dw, _dwa, _dw); + + // step size determination (Mehrotra´s adaptive algorithm) + + zmin = HUGE_VAL; + izmin = -1; + wmin = HUGE_VAL; + iwmin = -1; + for ( i = 0; i < _m; i++ ) { + if ( ( _logging ) && ( _z->ve[i] <= 0.0 ) ) + printf("_z[%d] = %g\n", i, _z->ve[i]); + if ( ( _logging ) && ( _w->ve[i] <= 0.0 ) ) + printf("_w[%d] = %g\n", i, _w->ve[i]); + if ( _dz->ve[i] > 0.0 ) + if ( _z->ve[i]/_dz->ve[i] < zmin ) { + izmin = i; + zmin = _z->ve[i]/_dz->ve[i]; + } + if ( _dw->ve[i] > 0.0 ) + if ( _w->ve[i]/_dw->ve[i] < wmin ) { + iwmin = i; + wmin = _w->ve[i]/_dw->ve[i]; + } + } + + if ( ( izmin < 0 ) && ( iwmin < 0 ) ) + _alpha = 1.0; + else { + if ( izmin < 0 ) + _alpha = wmin; + else if ( iwmin < 0 ) + _alpha = zmin; + else + _alpha = min(zmin, wmin); + v_mltadd(_z, _dz, -_alpha, _r3); + v_mltadd(_w, _dw, -_alpha, _r4); + mu_pl = in_prod(_r3, _r4)/_m; + if ( ( _alpha == wmin ) && ( _z->ve[iwmin] > _alpha*_dz->ve[iwmin] ) ) + fpd = 1.0-_gammaf*mu_pl/_w->ve[iwmin]/ + (_z->ve[iwmin]-_alpha*_dz->ve[iwmin]); + else if ( ( _alpha == zmin ) && ( _w->ve[izmin] > _alpha*_dw->ve[izmin] ) ) + fpd = 1.0-_gammaf*mu_pl/_z->ve[izmin]/ + (_w->ve[izmin]-_alpha*_dw->ve[izmin]); + else + fpd = 0; + _alpha = min(max(1-_gammaf, fpd),1.0-MACHEPS)*_alpha; + } + + _alpha = max(0.0, min(_alpha, 1.0)); + + if ( _logging ) + printf("%8.2g %8.2g\n", sigma, _alpha); + + // perform step + + v_mltadd(_qp->x, _dx, -_alpha, _dx); + v_mltadd(_y, _dy, -_alpha, _y); + v_mltadd(_z, _dz, -_alpha, _z); + v_mltadd(_w, _dw, -_alpha, _w); + + mu = in_prod(_z, _w); + + if (!is_finite(mu) || !is_finite(v_norm_inf(_dx))) { + _result = Hqp_Degenerate; + + if ( _logging ) + printf("\nHQP_Degenerate: mu = %g, _dx = %g\n", mu, v_norm_inf(_dx)); + return IF_OK; + } + + v_copy(_dx, _qp->x); + _iter++; + + return IF_OK; +} + +//-------------------------------------------------------------------------- +int Hqp_IpsMehrotra::solve(int, char *[], char **ret) +{ + Real test1 = 0.0; + + _fail_iters = 0; + + do { + do { + step(); + if (_hot_started) { + if (_iter == 1) { + test1 = _test; + } else + // 5/5/98 2.0 --> 1.2 + if ( ( _test > test1/pow(1.2,_iter-1.0) ) || ( _alpha < 1.0e-5 ) ) { + //printf("Restarted cold after %d iters (%g)\n", _iter, _test); + _fail_iters += _iter; + cold_start(); + } + } + + if (_iter + _fail_iters >= _max_iters) break; + if (_hot_started && _iter >= _max_warm_iters) break; + + } while (_result != Hqp_Optimal + && _result != Hqp_Suboptimal && _result != Hqp_Degenerate); + + if (_hot_started && _result != Hqp_Optimal) { + //fprintf(stderr, "Bad hot-start, lost %d iters\n", _iter); + _fail_iters += _iter; + cold_start(); + } else + break; + + } while (1); + + _iter += _fail_iters; + + return IF_OK; +} + +//========================================================================== + + diff --git a/hqp/Hqp_IpsMehrotra.h b/hqp/Hqp_IpsMehrotra.h new file mode 100644 index 0000000..0f3b024 --- /dev/null +++ b/hqp/Hqp_IpsMehrotra.h @@ -0,0 +1,99 @@ +/* + * Hqp_IpsMehrotra.h -- + * - interior point algorithm for solving quadratic programs + * - uses a Hqp_IpMatrix for performing iterates + * rf, 5/28/94 + * + * rf, 9/14/96 + * - extended interface to Hqp_IpMatrix + * ea, 5/9/97 + * - Mehrotra´s primal-dual predictor-corrector method for QP problems. + * S. J. Wright: Primal-dual interior-point methods. + * SIAM, Philadelphia, 1997. + */ + +/* + Copyright (C) 1994--1998 Eckhard Arnold and Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_IpsMehrotra_H +#define Hqp_IpsMehrotra_H + +#include "Hqp_Solver.h" + +class Hqp_Program; +class Hqp_IpMatrix; + +class Hqp_IpsMehrotra: public Hqp_Solver { + + protected: + int _n, _me, _m; + VEC *_w; // vector of slacks + VEC *_r1; // right hand sides + VEC *_r2; + VEC *_r3; + VEC *_r4; + VEC *_dx; // modifications for one step + VEC *_dy; + VEC *_dz; + VEC *_dw; + VEC *_dxa; // affine step + VEC *_dya; + VEC *_dza; + VEC *_dwa; + VEC *_z_hot; // hot start + VEC *_w_hot; + VEC *_phimin; // convergence check + Real _mu0; // used for cold start + Real _zeta; // not used! + Real _alpha; // step length + Real _gammaf; + Real _beta; // not used! + Real _gap; // duality gap??? + Real _test; // KKT residual + + Hqp_IpMatrix *_matrix; + + int _hot_started; // flag + int _fail_iters; // lost iters after a failed warm start + int _max_warm_iters; + int _logging; // output + + public: + + Hqp_IpsMehrotra(); + ~Hqp_IpsMehrotra(); + + // initializing a program + int init(IF_DEF_ARGS); + int update(IF_DEF_ARGS); + + // solving a program + int cold_start(IF_DEF_ARGS); + int hot_start(IF_DEF_ARGS); + int step(IF_DEF_ARGS); + int solve(IF_DEF_ARGS); + + // member access + Real gap() {return _gap;} + Real zeta() {return _zeta;} + + char *name() {return "Mehrotra";} +}; + +#endif diff --git a/hqp/Hqp_Program.C b/hqp/Hqp_Program.C new file mode 100644 index 0000000..1dfb875 --- /dev/null +++ b/hqp/Hqp_Program.C @@ -0,0 +1,115 @@ +/* + * Hqp_Program.C + * + * rf, 5/15/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include +#include + +#include "Hqp_Program.h" + +//------------------------------------------------------------------------- +Hqp_Program::Hqp_Program() +{ + x = VNULL; + Q = A = C = SMNULL; + c = b = d = VNULL; +} + +//------------------------------------------------------------------------- +Hqp_Program::~Hqp_Program() +{ + v_free(x); + sp_free(Q); + v_free(c); + sp_free(A); + v_free(b); + sp_free(C); + v_free(d); +} + +//------------------------------------------------------------------------- +void Hqp_Program::resize(int n, int me, int m, + int el_n, int el_me, int el_m) +{ + double log2; + + sp_free(Q); + sp_free(A); + sp_free(C); + + log2 = log(2.0); + if (el_n < 1) + el_n = n > 0? 1 + (int)(log((double)n) / log2): 0; + if (el_me < 1) + el_me = me > 0? 1 + (int)(log((double)me) / log2): 0; + if (el_m < 1) + el_m = m > 0? 1 + (int)(log((double)m) / log2): 0; + + x = v_resize(x, n); + + Q = sp_get(n, n, el_n); + c = v_resize(c, n); + + A = sp_get(me, n, el_me); + b = v_resize(b, me); + + C = sp_get(m, n, el_m); + d = v_resize(d, m); +} + +//------------------------------------------------------------------------- +void Hqp_Program::foutput(FILE *fp) +{ + fprintf(fp, "# Quadratic Program\n"); + fprintf(fp, "# criterion: 1/2 x'Qx + c'x -> min\n"); + fprintf(fp, "# equality constraints: Ax + b = 0\n"); + fprintf(fp, "# inequality constraints: Cx + d >= 0\n"); + + fprintf(fp, "#\n"); + fprintf(fp, "# Q:\n"); + sp_foutput(fp, Q); + + fprintf(fp, "#\n"); + fprintf(fp, "# c:\n"); + v_foutput(fp, c); + + fprintf(fp, "#\n"); + fprintf(fp, "# A:\n"); + sp_foutput(fp, A); + + fprintf(fp, "#\n"); + fprintf(fp, "# b:\n"); + v_foutput(fp, b); + + fprintf(fp, "#\n"); + fprintf(fp, "# C:\n"); + sp_foutput(fp, C); + + fprintf(fp, "#\n"); + fprintf(fp, "# d:\n"); + v_foutput(fp, d); +} + +//========================================================================= diff --git a/hqp/Hqp_Program.h b/hqp/Hqp_Program.h new file mode 100644 index 0000000..b4043af --- /dev/null +++ b/hqp/Hqp_Program.h @@ -0,0 +1,57 @@ +/* + * Hqp_Program.h -- program for sparse quadratic programming + * + * rf, 5/15/94 + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_Program_H +#define Hqp_Program_H + +#include "Hqp_impl.h" + + +class Hqp_Program { + + public: + + VECP x; // variables to optimize on + + SPMATP Q; // criterion: 1/2 x'Qx + c'x -> min + VECP c; + + SPMATP A; // equality constraints: Ax + b = 0 + VECP b; + + SPMATP C; // inequality constraints: Cx + d >= 0 + VECP d; + + Hqp_Program(); + ~Hqp_Program(); + + void resize(int n, int me, int m, + int el_n = 0, int el_me = 0, int el_m = 0); + void foutput(FILE *fp); +}; + +#endif + + diff --git a/hqp/Hqp_Solver.C b/hqp/Hqp_Solver.C new file mode 100644 index 0000000..05a168b --- /dev/null +++ b/hqp/Hqp_Solver.C @@ -0,0 +1,76 @@ +/* + * Hqp_Solver.C -- + * - class definition + * + * rf, 7/19/94 + * + * rf, 8/13/98 + * - make Hqp_Solver a visible interface class + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include +#include + +#include "Hqp_Solver.h" +#include "Hqp_Program.h" + +IF_BASE_DEFINE(Hqp_Solver); + +typedef If_Method If_Cmd; + +//-------------------------------------------------------------------------- +Hqp_Solver::Hqp_Solver() +{ + _qp = NULL; + _result = Hqp_Infeasible; + _iter = 0; + _max_iters = 200; + _eps = 1e-10; + _y = VNULL; + _z = VNULL; + + _ifList.append(new If_Int("qp_iter", &_iter)); + _ifList.append(new If_Int("qp_max_iters", &_max_iters)); + _ifList.append(new If_Float("qp_eps", &_eps)); + _ifList.append(new If_Cmd("qp_result", &Hqp_Solver::result_str, this)); +} + +//-------------------------------------------------------------------------- +Hqp_Solver::~Hqp_Solver() +{ + v_free(_y); + v_free(_z); +} + +//-------------------------------------------------------------------------- +int Hqp_Solver::result_str(int, char *[], char **result) +{ + *result = (char *)hqp_result_strings[_result]; + return IF_OK; +} + +//-------------------------------------------------------------------------- +void Hqp_Solver::qp(Hqp_Program *qp) +{ + _qp = qp; +} diff --git a/hqp/Hqp_Solver.h b/hqp/Hqp_Solver.h new file mode 100644 index 0000000..b3bc9a3 --- /dev/null +++ b/hqp/Hqp_Solver.h @@ -0,0 +1,93 @@ +/* + * Hqp_Solver.h -- + * - abstract base class for a quadratic solver + * + * rf, 7/19/94 + * + * rf, 8/13/98 + * - make Hqp_Solver a visible interface class + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_Solver_H +#define Hqp_Solver_H + +#include +#include +#include + +#include "Hqp_impl.h" + +class Hqp_Program; + +IF_BASE_DECLARE(Hqp_Solver); + +class Hqp_Solver { + + protected: + + If_List _ifList; + + Hqp_Program *_qp; // program to work with + Hqp_Result _result; // current processing state + + int _iter; + int _max_iters; + Real _eps; + + VEC *_y; // multiplicators for equalities + VEC *_z; // multiplicators for inequalities + + public: + + Hqp_Solver(); + virtual ~Hqp_Solver(); + + void qp(Hqp_Program *); + + // initializing a program (updating for SQP integration) + virtual int init(IF_DEF_ARGS)=0; + virtual int update(IF_DEF_ARGS)=0; + + // solving a program (hot start for SQP integration) + virtual int cold_start(IF_DEF_ARGS)=0; + virtual int hot_start(IF_DEF_ARGS)=0; + virtual int step(IF_DEF_ARGS)=0; + virtual int solve(IF_DEF_ARGS)=0; + + // member access + int result_str(IF_CMD_ARGS); + Hqp_Result result() {return _result;} + int iter() {return _iter;} + int max_iters() {return _max_iters;} + void max_iters(int n_max_iters) {_max_iters = n_max_iters;} + Real eps() {return _eps;} + void eps(Real n_eps) {_eps = n_eps;} + const VEC *y() {return _y;} + const VEC *z() {return _z;} + + // interface name + virtual char *name()=0; +}; + +#endif + + diff --git a/hqp/Hqp_SqpPowell.C b/hqp/Hqp_SqpPowell.C new file mode 100644 index 0000000..d452a72 --- /dev/null +++ b/hqp/Hqp_SqpPowell.C @@ -0,0 +1,396 @@ +/* + * Hqp_SqpPowell.C -- class definition + * + * rf, 6/8/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include + +#include +#include +#include + +#include "Hqp_SqpPowell.h" +#include "Hqp_Solver.h" +#include "Hqp_SqpProgram.h" +#include "Hqp_Program.h" + +typedef If_Method If_Cmd; + +IF_CLASS_DEFINE("Powell", Hqp_SqpPowell, Hqp_SqpSolver); + +//-------------------------------------------------------------------------- +Hqp_SqpPowell::Hqp_SqpPowell() +{ + _relaxed = false; + _watchdog_iter = -1; + _watchdog_start = 10; + _watchdog_credit = 0; + _watchdog_logging = true; + _damped_multipliers = false; + _re = v_resize(v_get(1), 0); + _r = v_resize(v_get(1), 0); + _sy_y = v_resize(v_get(1), 0); + _sz_z = v_resize(v_get(1), 0); + _x0 = v_resize(v_get(1), 0); + _y0 = v_resize(v_get(1), 0); + _z0 = v_resize(v_get(1), 0); + _xk = v_resize(v_get(1), 0); + _xl = v_resize(v_get(1), 0); + _qp_xl = v_resize(v_get(1), 0); + _yl = v_resize(v_get(1), 0); + _zl = v_resize(v_get(1), 0); + + _ifList.append(new If_Int("sqp_watchdog_start", &_watchdog_start)); + _ifList.append(new If_Int("sqp_watchdog_credit", &_watchdog_credit)); + _ifList.append(new If_Bool("sqp_watchdog_logging", &_watchdog_logging)); + _ifList.append(new If_Bool("sqp_damped_multipliers", + &_damped_multipliers)); + _ifList.append(new If_Cmd("sqp_init", &Hqp_SqpPowell::init, this)); +} + +//-------------------------------------------------------------------------- +Hqp_SqpPowell::~Hqp_SqpPowell() +{ + v_free(_re); + v_free(_r); + v_free(_sy_y); + v_free(_sz_z); + v_free(_x0); + v_free(_y0); + v_free(_z0); + v_free(_xk); + v_free(_xl); + v_free(_qp_xl); + v_free(_yl); + v_free(_zl); +} + +//-------------------------------------------------------------------------- +int Hqp_SqpPowell::init(IF_CMD_ARGS) +{ + int ret = Hqp_SqpSolver::init(); + + Hqp_Program *qp = _prg->qp(); + + _x0 = v_resize(_x0, qp->c->dim); + _y0 = v_resize(_y0, qp->b->dim); + _z0 = v_resize(_z0, qp->d->dim); + _xk = v_resize(_xk, qp->c->dim); + _xl = v_resize(_xl, qp->c->dim); + _qp_xl = v_resize(_qp_xl, qp->c->dim); + _yl = v_resize(_yl, qp->b->dim); + _zl = v_resize(_zl, qp->d->dim); + _re = v_resize(_re, qp->b->dim); + _r = v_resize(_r, qp->d->dim); + _sy_y = v_resize(_sy_y, qp->b->dim); + _sz_z = v_resize(_sz_z, qp->d->dim); + + v_zero(_re); + v_zero(_r); + + _relaxed = false; + _watchdog_iter = -1; + + return ret; +} + +#if 1 +// Powell's algorithm +//-------------------------------------------------------------------------- +VEC *Hqp_SqpPowell::update_r(const VEC *z, VEC *r) +{ + int i, m; + const Real *ve1; + Real *ve2; + Real val1, val2; + + m = z->dim; + + if (_iter == 0) { + if (!r || (int)r->dim != m) + r = v_resize(r, m); + ve1 = z->ve; + ve2 = r->ve; + for (i=0; ive; + ve2 = r->ve; + for (i=0; i val2) + *ve2 = val1; + else + *ve2 = 0.5 * (val1 + val2); + } + } + + return r; +} + +#else +// Han's algorithm +//-------------------------------------------------------------------------- +VEC *Hqp_SqpPowell::update_r(const VEC *z, VEC *r) +{ + int i, m; + const Real *ve1; + Real *ve2; + Real val1, val2; + + m = z->dim; + + if (_iter == 0) { + if (!r || (int)r->dim != m) + r = v_resize(r, m); + ve1 = z->ve; + ve2 = r->ve; + for (i=0; ive; + ve2 = r->ve; + for (i=0; if(); + + ve1 = _prg->qp()->b->ve; + ve2 = _re->ve; + i_end = _re->dim; + for (i=0; iqp()->d->ve; + ve2 = _r->ve; + i_end = _r->dim; + for (i=0; iqp(); + int i, i_end; + const Real *ve1, *ve2; + Real ret; + VEC *g1 = VNULL; + + ret = _prg->f(); + ret += in_prod(qp->c, qp->x); + + g1 = sp_mv_mlt(qp->A, qp->x, g1); + v_add(g1, qp->b, g1); + ve1 = g1->ve; + ve2 = _re->ve; + i_end = _re->dim; + for (i=0; iC->m); // suspect in sp_mv_mlt of Mesch1.2b + g1 = sp_mv_mlt(qp->C, qp->x, g1); + v_add(g1, qp->d, g1); + ve1 = g1->ve; + ve2 = _r->ve; + i_end = _r->dim; + for (i=0; iqp(); + Real dphi0, phi0, phik; + Real n_alpha; + + // update penalty coeffizients + + if (_damped_multipliers) { + v_copy(_y, _y0); + v_copy(_z, _z0); + v_sub(_solver->y(), _y, _sy_y); + v_sub(_solver->z(), _z, _sz_z); + } + v_copy(_solver->y(), _y); + v_copy(_solver->z(), _z); + update_r(_solver->y(), _re); + update_r(_solver->z(), _r); + + // calculate penalty function + + _x0 = v_copy(_prg->x(), _x0); + phi0 = phik = phi(); + dphi0 = phi1() - phi0; + + if (dphi0 > 0.0) { + //printf("No descending direction (%g).\n", dphi0); + _alpha = _min_alpha; + } + else { + _alpha = 1.0; + } + + // watchdog + if (_watchdog_iter < 0) { + _phil_test = _phil; // phi0 from last iteration + _phil = phi0; + } + if (_watchdog_credit > 0 && _iter >= _watchdog_start) { + // Step 3 + if (phi0 <= _phil_test) { + _relaxed = true; + if (_watchdog_logging) { + printf("r"); + fflush(stdout); + } + // Step 4 (same test as for Step 3) + _watchdog_iter = _iter; + _xl = v_copy(_x0, _xl); + _qp_xl = v_copy(qp->x, _qp_xl); + _yl = v_copy(_y, _yl); + _zl = v_copy(_z, _zl); + _phil = phi0; + if (dphi0 < 0.0) // treat positive dphi0, e.g. near an optimizer + _phil_test += 0.1 * _min_alpha * dphi0; + } + else { + _relaxed = false; + if (_watchdog_logging) { + printf("s"); + fflush(stdout); + } + } + // Step 5 + if (_watchdog_iter >= 0 + && _iter >= _watchdog_iter + _watchdog_credit) { + + // backing store values from _watchdog_iter + _x0 = v_copy(_xl, _x0); + _prg->x(_x0); + _y = v_copy(_yl, _y); + _z = v_copy(_zl, _z); + _prg->update(_y, _z); + qp->x = v_copy(_qp_xl, qp->x); + hela_restart(); + + // update penalties + if (_damped_multipliers) { + v_copy(_y, _y0); + v_copy(_z, _z0); + v_zero(_sy_y); + v_zero(_sz_z); + } + update_r(_y, _re); + update_r(_z, _r); + phi0 = phik = phi(); + dphi0 = phi1() - phi0; + + _phil = phi0; + _relaxed = false; + _watchdog_iter = -1; + + if (_watchdog_logging) { + printf("b"); + fflush(stdout); + } + } + } + + // obtain step size + + while (1) { + _d = sv_mlt(_alpha, qp->x, _d); + v_add(_x0, _d, _xk); + if (_damped_multipliers && _alpha < 1.0) { + v_mltadd(_y0, _sy_y, _alpha, _y); + v_mltadd(_z0, _sz_z, _alpha, _z); + } + _prg->x(_xk); + if (_alpha <= _min_alpha) + break; + if (_relaxed && _watchdog_credit > 0) + // accept step length 1 + break; + _prg->update_fbd(); + if (!is_finite(_prg->f())) { + _alpha *= 0.1; + continue; + } + phik = phi(); + if (phik <= (phi0 + 0.1 * _alpha * dphi0) || fabs(dphi0) <= _eps) + break; + n_alpha = 0.5*dphi0*_alpha*_alpha / (dphi0 * _alpha - (phik - phi0)); + if (fabs(_alpha - n_alpha) < _min_alpha) + break; + _alpha *= 0.1; + _alpha = max(_alpha, n_alpha); + _alpha = max(_alpha, _min_alpha); + } + + _dphi = dphi0; + _phi = phi0; +} + +//-------------------------------------------------------------------------- +Real Hqp_SqpPowell::val_L() +{ + Hqp_Program *qp = _prg->qp(); + Real ret; + + ret = _prg->f(); + ret -= in_prod(_y, qp->b); + ret -= in_prod(_z, qp->d); + + return ret; +} + +//========================================================================== diff --git a/hqp/Hqp_SqpPowell.h b/hqp/Hqp_SqpPowell.h new file mode 100644 index 0000000..14a541c --- /dev/null +++ b/hqp/Hqp_SqpPowell.h @@ -0,0 +1,76 @@ +/* + * Hqp_SqpPowell.h -- + * - Powells SQP algorithm + * + * rf, 6/8/94 + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_SqpPowell_H +#define Hqp_SqpPowell_H + +#include "Hqp_SqpSolver.h" + +class Hqp_SqpProgram; + + +class Hqp_SqpPowell: public Hqp_SqpSolver { + + protected: + bool _relaxed; + int _watchdog_start; // first allowed watchdog iteration + int _watchdog_credit; // allowed number of bad iterations + int _watchdog_iter; // iteration for backtracking + bool _watchdog_logging; + bool _damped_multipliers; + Real _phil; + Real _phil_test; + VEC *_re; // penalty coeffizients for equality constraints + VEC *_r; // penalty coeffizients for inequality constraints + VEC *_sy_y; + VEC *_sz_z; + VEC *_x0; + VEC *_y0; + VEC *_z0; + VEC *_xk; + VEC *_xl; // backing store for watchdog + VEC *_qp_xl; + VEC *_yl; + VEC *_zl; + + Real phi(); + Real phi1(); + VEC *update_r(const VEC *z, VEC *r); + + void update_vals(); + Real val_L(); + + public: + Hqp_SqpPowell(); + ~Hqp_SqpPowell(); + + int init(IF_DEF_ARGS); + + char *name() {return "Powell";} +}; + + +#endif diff --git a/hqp/Hqp_SqpProgram.C b/hqp/Hqp_SqpProgram.C new file mode 100644 index 0000000..655e03e --- /dev/null +++ b/hqp/Hqp_SqpProgram.C @@ -0,0 +1,234 @@ +/* + * Hqp_SqpProgram.C -- class definition + * + * rf, 6/6/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include +#include +#include +#include +#include + +#include +#include +#include + +#include "Hqp_SqpSolver.h" +#include "Hqp_SqpProgram.h" +#include "Hqp_Program.h" + +// let currently created program be nodified by theSqpSolver +//---------------------------------------------------------- +extern Hqp_SqpSolver *theSqpSolver; + +typedef If_Method If_Cmd; + +IF_BASE_DEFINE(Hqp_SqpProgram); + +//------------------------------------------------------------------------- +Hqp_SqpProgram::Hqp_SqpProgram() +{ + _qp = new Hqp_Program; + _x = v_resize(v_get(1), 0); + _f = 0.0; + + theSqpSolver->set_prg(this); + + _ifList.append(new If_Float("prg_f", &_f)); + _ifList.append(new If_FloatVec("prg_x", &_x)); + _ifList.append(new If_Cmd("prg_setup", &Hqp_SqpProgram::setup_cmd, this)); + _ifList.append(new If_Cmd("prg_init_x", &Hqp_SqpProgram::init_x_cmd, this)); + _ifList.append(new If_Cmd("prg_test", &Hqp_SqpProgram::test_cmd, this)); + _ifList.append(new If_Cmd("prg_qp_dump", + &Hqp_SqpProgram::qp_dump_cmd, this)); + _ifList.append(new If_Cmd("prg_update_fbd", + &Hqp_SqpProgram::update_fbd_cmd, this)); +} + +//------------------------------------------------------------------------- +Hqp_SqpProgram::~Hqp_SqpProgram() +{ + delete _qp; + v_free(_x); +} + +//------------------------------------------------------------------------- +void Hqp_SqpProgram::x(const VECP n_x) +{ + assert(n_x->dim == _x->dim); + v_copy(n_x, _x); +} + +//------------------------------------------------------------------------- +void Hqp_SqpProgram::reinit_bd() +{ + // do nothing per default +} + +//------------------------------------------------------------------------- +int Hqp_SqpProgram::setup_cmd(IF_CMD_ARGS) +{ + setup(); + + return IF_OK; +} + +//------------------------------------------------------------------------- +int Hqp_SqpProgram::init_x_cmd(IF_CMD_ARGS) +{ + init_x(); + + return IF_OK; +} + +//------------------------------------------------------------------------- +// write difference between approximated and calculated gradients into qp +// -- _x, _f, and _qp must be initialized before +// -- results are stored in _qp->c, _qp->A, and _qp->C +// (--> program should be reinitialzed afterwards) +// -- returns maximal found error +// +int Hqp_SqpProgram::test_cmd(int, char *[], char **result) +{ + static char maxstr[15]; + int i, j, idx; + int xdim = _x->dim; + int bdim = _qp->b->dim; + int ddim = _qp->d->dim; + Real xi_bak, dxi, f_bak; + VECP dc, b_bak, d_bak; + Real *ve; + SPROW *row; + Real val, maxval = 0.0; + + f_bak = _f; + dc = v_get(xdim); + b_bak = v_copy(_qp->b, VNULL); + d_bak = v_copy(_qp->d, VNULL); + for (i=0; ib, b_bak, _qp->b); + sv_mlt(1.0/dxi, _qp->b, _qp->b); + ve = _qp->b->ve; + row = _qp->A->row; + for (j=0; j= 0) + val = row->elt[idx].val = *ve - row->elt[idx].val; + else + val = sp_set_val(_qp->A, j, i, *ve); + maxval = max(maxval, fabs(val)); + } + + v_sub(_qp->d, d_bak, _qp->d); + sv_mlt(1.0/dxi, _qp->d, _qp->d); + ve = _qp->d->ve; + row = _qp->C->row; + for (j=0; j= 0) + val = row->elt[idx].val = *ve - row->elt[idx].val; + else + val = sp_set_val(_qp->C, j, i, *ve); + maxval = max(maxval, fabs(val)); + } + } + _f = f_bak; + + v_sub(dc, _qp->c, _qp->c); + maxval = max(maxval, v_max(_qp->c, &i)); + maxval = max(maxval, -v_min(_qp->c, &i)); + + if (result) { + sprintf(maxstr, "%.5g", maxval); + *result = maxstr; + } + + v_copy(b_bak, _qp->b); + v_copy(d_bak, _qp->d); + + v_free(dc); + v_free(b_bak); + v_free(d_bak); + + return IF_OK; +} + +//------------------------------------------------------------------------- +int Hqp_SqpProgram::qp_dump_cmd(int argc, char *argv[], char **result) +{ + int fd; + char *pos; + FILE *fp; + + if (argc != 2) { + *result = "wrong # args, should be: prg_qp_dump [|]"; + return IF_ERROR; + } + + // try to interpret argv[1] as filedescriptor + // if this fails, then create file with name argv[1] + + fd = (int)strtol(argv[1], &pos, 0); + if (pos != argv[1]) { + fp = fdopen(fd, "w"); + if (fp == NULL) { + *result = strerror(errno); + return IF_ERROR; + } + _qp->foutput(fp); + } + else { + fp = fopen(argv[1], "w"); + if (fp == NULL) { + *result = "can't open file for writing"; + return IF_ERROR; + } + _qp->foutput(fp); + fclose(fp); + } + + return IF_OK; +} + +//------------------------------------------------------------------------- +int Hqp_SqpProgram::update_fbd_cmd(int argc, char *argv[], char **result) +{ + update_fbd(); + return IF_OK; +} + + +//========================================================================= diff --git a/hqp/Hqp_SqpProgram.h b/hqp/Hqp_SqpProgram.h new file mode 100644 index 0000000..2af4ccf --- /dev/null +++ b/hqp/Hqp_SqpProgram.h @@ -0,0 +1,94 @@ +/* + * Hqp_SqpProgram.h -- + * - base class for formulating nonlinear programs for solving with + * sequential quadratic programming + * - constructor has to allocate _x and sparsity structure in _qp + * - additional methods provide value updates for SQP iterations + * + * rf, 6/6/94 + * + * rf, 1/25/97 + * - new interface command prg_update_fbd that calls update_fbd + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_SqpProgram_H +#define Hqp_SqpProgram_H + +#include +#include +#include + +#include "Hqp_impl.h" + +class Hqp_Program; + +IF_BASE_DECLARE(Hqp_SqpProgram); + +//-------------------- +class Hqp_SqpProgram { + + protected: + + If_List _ifList; + + Hqp_Program *_qp; // quadratic approximation + VECP _x; // vector of variables + Real _f; // objective value + + public: + + Hqp_SqpProgram(); + virtual ~Hqp_SqpProgram(); + + int setup_cmd(IF_DEF_ARGS); + int init_x_cmd(IF_DEF_ARGS); + int test_cmd(IF_DEF_ARGS); + int qp_dump_cmd(IF_CMD_ARGS); + int update_fbd_cmd(IF_CMD_ARGS); + + // methods to define a program + //---------------------------- + virtual void setup()=0; // realloc _qp, set up sparsity pattern + virtual void init_x()=0; // set start variables + + virtual void update_fbd()=0; // update values for _qp according to _x + virtual void update(const VECP y, const VECP z)=0; // update everything + + virtual void reinit_bd(); // re-initialize constants in constraints + + // member access + // --> x(const VECP) may be overloaded for recomputing cached data + //---------------------------------------------------------------- + virtual Hqp_Program *qp() {return _qp;} + + virtual const VECP x() {return _x;} + virtual void x(const VECP); + + virtual Real f() {return _f;} + virtual void f(Real f) {_f = f;} // needed by Hqp_HL::init() + + virtual char *name()=0; +}; + +#endif + + diff --git a/hqp/Hqp_SqpSchittkowski.C b/hqp/Hqp_SqpSchittkowski.C new file mode 100644 index 0000000..a4b4b21 --- /dev/null +++ b/hqp/Hqp_SqpSchittkowski.C @@ -0,0 +1,332 @@ +/* + * Hqp_SqpSchittkowski.C -- class definition + * + * rf, 6/8/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include + +#include +#include +#include + +#include "Hqp_SqpSchittkowski.h" +#include "Hqp_Solver.h" +#include "Hqp_SqpProgram.h" +#include "Hqp_Program.h" + +typedef If_Method If_Cmd; + +IF_CLASS_DEFINE("Schittkowski", Hqp_SqpSchittkowski, Hqp_SqpSolver); + +//-------------------------------------------------------------------------- +Hqp_SqpSchittkowski::Hqp_SqpSchittkowski() +{ + _x0 = v_resize(v_get(1), 0); + _xk = v_resize(v_get(1), 0); + _re = v_resize(v_get(1), 0); + _r = v_resize(v_get(1), 0); + _ve = v_resize(v_get(1), 0); + _v = v_resize(v_get(1), 0); + _v0 = v_resize(v_get(1), 0); + _ve0 = v_resize(v_get(1), 0); + _ue_ve = v_resize(v_get(1), 0); + _u_v = v_resize(v_get(1), 0); + _sgme = v_resize(v_get(1), 0); + _sgm = v_resize(v_get(1), 0); + + _mu = 0.1; + _beta = 0.1; + _damped_multipliers = true; + + _ifList.append(new If_Float("sqp_mu", &_mu)); + _ifList.append(new If_Float("sqp_beta", &_beta)); + _ifList.append(new If_Bool("sqp_damped_multipliers", + &_damped_multipliers)); + _ifList.append(new If_Cmd("sqp_init", &Hqp_SqpSchittkowski::init, this)); +} + +//-------------------------------------------------------------------------- +Hqp_SqpSchittkowski::~Hqp_SqpSchittkowski() +{ + v_free(_x0); + v_free(_xk); + v_free(_re); + v_free(_r); + v_free(_ve); + v_free(_v); + v_free(_v0); + v_free(_ve0); + v_free(_ue_ve); + v_free(_u_v); + v_free(_sgme); + v_free(_sgm); +} + +//-------------------------------------------------------------------------- +int Hqp_SqpSchittkowski::init(IF_CMD_ARGS) +{ + int ret = Hqp_SqpSolver::init(); + + Hqp_Program *qp = _prg->qp(); + + int n = qp->c->dim; + int me = qp->b->dim; + int m = qp->d->dim; + + _x0 = v_resize(_x0, n); + _xk = v_resize(_xk, n); + _re = v_resize(_re, me); + _r = v_resize(_r, m); + _ve = v_resize(_ve, me); + _v = v_resize(_v, m); + _ve0 = v_resize(_ve0, me); + _v0 = v_resize(_v0, m); + _ue_ve = v_resize(_ue_ve, me); + _u_v = v_resize(_u_v, m); + _sgme = v_resize(_sgme, me); + _sgm = v_resize(_sgm, m); + + v_ones(_re); + v_ones(_r); + v_zero(_ve); + v_zero(_v); + + return ret; +} + +//-------------------------------------------------------------------------- +VEC *Hqp_SqpSchittkowski::update_sgm(const VEC *r, VEC *sgm) +{ + int i, m; + const Real *r_ve; + Real *sgm_ve; + Real val; + + m = sgm->dim; + r_ve = r->ve; + sgm_ve = sgm->ve; + for (i=0; idim + _r->dim); + i_end = u->dim; + u_ve = u->ve; + v_ve = v->ve; + sgm_ve = sgm->ve; + r_ve = r->ve; + for (i=0; i val1) // says no for when val2 == NaN + *r_ve = val2; + else + *r_ve = val1; + } + + return r; +} + +//-------------------------------------------------------------------------- +Real Hqp_SqpSchittkowski::phi() +{ + int i, i_end; + const Real *v_ve, *r_ve, *g_ve; + Real g, v; + Real ret; + + ret = _prg->f(); + + v_ve = _ve->ve; + r_ve = _re->ve; + g_ve = _prg->qp()->b->ve; + i_end = _re->dim; + for (i=0; ive; + r_ve = _r->ve; + g_ve = _prg->qp()->d->ve; + i_end = _r->dim; + for (i=0; iqp(); + int i, i_end; + const Real *v_ve, *r_ve, *g_ve; + Real val, *phiv_ve; + VEC *phix, *phive, *phiv; + VEC *v_rg = VNULL; + Real ret; + + // (d Phi / d ve) belongs completely to intex set J + + phive = sv_mlt(-1.0, qp->b, VNULL); + + // initialize (d Phi / d x) with (d f / d x) and equality constraints + + phix = v_copy(qp->c, VNULL); + v_rg = v_star(_re, qp->b, v_rg); + v_sub(_ve, v_rg, v_rg); + sp_vm_mltadd(phix, v_rg, qp->A, -1.0, phix); + + // do a loop to calculate (d Phi / d v) and to get index sets + // use v_rg for calculating inequality-part of (d Phi / d x) + + v_rg = v_star(_r, qp->d, v_rg); + v_sub(_v, v_rg, v_rg); + + phiv = v_get(_v->dim); + phiv_ve = phiv->ve; + g_ve = qp->d->ve; + v_ve = _v->ve; + r_ve = _r->ve; + i_end = _v->dim; + for (i=0; ive[i] = 0.0; + } + } + + // actualize (d Phi / d x) with inequality constraints of index set J + sp_vm_mltadd(phix, v_rg, qp->C, -1.0, phix); + + ret = in_prod(phix, qp->x); + ret += in_prod(phive, _ue_ve); + ret += in_prod(phiv, _u_v); + + v_free(phix); + v_free(phive); + v_free(phiv); + v_free(v_rg); + + return ret; +} + +//-------------------------------------------------------------------------- +void Hqp_SqpSchittkowski::update_vals() +{ + Hqp_Program *qp = _prg->qp(); + Real dphi0, phi0, phik; + Real n_alpha; + + // update penalty coeffizients + + update_sgm(_re, _sgme); + update_sgm(_r, _sgm); + _y = v_copy(_solver->y(), _y); + _z = v_copy(_solver->z(), _z); + update_r(_solver->y(), _ve, _sgme, _sQs, _re); + update_r(_solver->z(), _v, _sgm, _sQs, _r); + + // find step length and update _prg->x() + + _ue_ve = v_sub(_solver->y(), _ve, _ue_ve); + _u_v = v_sub(_solver->z(), _v, _u_v); + + _x0 = v_copy(_prg->x(), _x0); + _ve0 = v_copy(_ve, _ve0); + _v0 = v_copy(_v, _v0); + phi0 = phik = phi(); + dphi0 = dphi(); + + if (dphi0 > 0.0) { +// printf("No descending direction (%g).\n", dphi0); + _alpha = _min_alpha; + } + else { + _alpha = 1.0; + } + while (1) { + _d = sv_mlt(_alpha, qp->x, _d); + v_add(_x0, _d, _xk); + v_mltadd(_ve0, _ue_ve, _alpha, _ve); + v_mltadd(_v0, _u_v, _alpha, _v); + if (_damped_multipliers && _alpha < 1.0) { + v_copy(_ve, _y); + v_copy(_v, _z); + } + _prg->x(_xk); + _prg->update_fbd(); + if (!is_finite(_prg->f())) { + _alpha *= 0.1; + continue; + } + if (_alpha <= _min_alpha) + break; + phik = phi(); + if (phik <= (phi0 + _mu * _alpha * dphi0) || fabs(dphi0) <= _eps) + break; + n_alpha = 0.5 * dphi0 * _alpha*_alpha / (dphi0 * _alpha - (phik - phi0)); + /* + if (fabs(_alpha - n_alpha) < _min_alpha) + break; + */ + if (!(n_alpha < _alpha)) + break; + _alpha *= _beta; + _alpha = max(_alpha, n_alpha); + } + _dphi = dphi0; + _phi = phi0; +} + + +//========================================================================== diff --git a/hqp/Hqp_SqpSchittkowski.h b/hqp/Hqp_SqpSchittkowski.h new file mode 100644 index 0000000..77b4b42 --- /dev/null +++ b/hqp/Hqp_SqpSchittkowski.h @@ -0,0 +1,74 @@ +/* + * Hqp_SqpSchittkowski.h -- + * - Schittkowski's SQP algorithm + * + * rf, 6/8/94 + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_SqpSchittkowski_H +#define Hqp_SqpSchittkowski_H + +#include "Hqp_SqpSolver.h" + +class Hqp_SqpProgram; + + +class Hqp_SqpSchittkowski: public Hqp_SqpSolver { + + protected: + VEC *_x0; // start vector for line search + VEC *_xk; // currently treated vector + VEC *_re; // penalty coeffizients for equality constraints + VEC *_r; // penalty coeffizients for inequality constraints + VEC *_ve; + VEC *_v; + VEC *_v0; + VEC *_ve0; + VEC *_ue_ve; + VEC *_u_v; + VEC *_sgme; + VEC *_sgm; + + Real _mu; + Real _eps; + Real _beta; + bool _damped_multipliers; + + Real phi(); + Real dphi(); + VEC *update_sgm(const VEC *r, VEC *sgm); + VEC *update_r(const VEC *u, const VEC *v, const VEC *sgm, + Real dQd, VEC *r); + + void update_vals(); + + public: + Hqp_SqpSchittkowski(); + ~Hqp_SqpSchittkowski(); + + int init(IF_DEF_ARGS); + + char *name() {return "Schittkowski";} +}; + + +#endif diff --git a/hqp/Hqp_SqpSolver.C b/hqp/Hqp_SqpSolver.C new file mode 100644 index 0000000..c7f3b6f --- /dev/null +++ b/hqp/Hqp_SqpSolver.C @@ -0,0 +1,465 @@ +/* + * Hqp_SqpSolver.C -- class definition + * + * rf, 6/6/94 + * + * rf, 8/13/98 + * - make Hqp_Solver an exchangeable interface class + * + * rf, 12/23/99 + * - extended member access methods + * + */ + +/* + Copyright (C) 1994--1999 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include + +#include +#include +#include +#include +#include +#include + +#include "Hqp_SqpSolver.h" +#include "Hqp_Program.h" +#include "Hqp_SqpProgram.h" +#include "Hqp_IpsFranke.h" +#include "Hqp_Client.h" + +#include "Hqp_HL_BFGS.h" + +extern Hqp_SqpProgram *theSqpProgram; + +typedef If_Method If_Cmd; + +IF_BASE_DEFINE(Hqp_SqpSolver); + +//-------------------------------------------------------------------------- +Hqp_SqpSolver::Hqp_SqpSolver() +{ + _prg = NULL; + _x0 = v_resize(v_get(1), 0); + _xk = v_resize(v_get(1), 0); + _d = v_resize(v_get(1), 0); + _y = v_resize(v_get(1), 0); + _z = v_resize(v_get(1), 0); + _dL = v_resize(v_get(1), 0); + _grd_L = v_resize(v_get(1), 0); + _solver = new Hqp_IpsFranke; + _hela = new Hqp_HL_BFGS; + _iter = 0; + _max_iters = 500; + _inf_iters = 0; + _max_inf_iters = 10; + _alpha = 1.0; + _min_alpha = 1e-10; + _phi = 0.0; + _dphi = 0.0; + _sQs = 0.0; + _xQx = 0.0; + _eps = 1e-6; + _solver->eps(1e-10); + _norm_dx = 0.0; + _norm_x = 0.0; + _norm_inf = 0.0; + _norm_grd_L = 0.0; + _norm_df = 0.0; + _f_bak = 0.0; + _logging = false; + + _hot_started = false; + _qp_Q_hot = SMNULL; + + if (theSqpProgram) + set_prg(theSqpProgram); + + _ifList.append(new If_Int("sqp_iter", &_iter)); + _ifList.append(new If_Int("sqp_max_iters", &_max_iters)); + _ifList.append(new If_Int("sqp_inf_iters", &_inf_iters)); + _ifList.append(new If_Int("sqp_max_inf_iters", &_max_inf_iters)); + _ifList.append(new If_Bool("sqp_logging", &_logging)); + _ifList.append(new If_Float("sqp_eps", &_eps)); + _ifList.append(new If_Float("sqp_alpha", &_alpha)); + _ifList.append(new If_Float("sqp_min_alpha", &_min_alpha)); + _ifList.append(new If_Float("sqp_norm_s", &_norm_dx)); + _ifList.append(new If_Float("sqp_norm_x", &_norm_x)); + _ifList.append(new If_Float("sqp_norm_inf", &_norm_inf)); + _ifList.append(new If_Float("sqp_norm_grd_L", &_norm_grd_L)); + _ifList.append(new If_Float("sqp_norm_df", &_norm_df)); + _ifList.append(new If_Float("sqp_dphi", &_dphi)); + _ifList.append(new If_Float("sqp_phi", &_phi)); + _ifList.append(new If_Float("sqp_sQs", &_sQs)); + _ifList.append(new If_Float("sqp_xQx", &_xQx)); + _ifList.append(new If_FloatVec("sqp_y", &_y)); + _ifList.append(new If_FloatVec("sqp_z", &_z)); + _ifList.append(new If_FloatVec("sqp_grd_L", &_grd_L)); + + _ifList.append(new IF_MODULE("sqp_qp_solver", &_solver, Hqp_Solver)); + _ifList.append(new IF_MODULE("sqp_hela", &_hela, Hqp_HL)); + + _ifList.append(new If_Cmd("sqp_init", &Hqp_SqpSolver::init, this)); + _ifList.append(new If_Cmd("sqp_qp_update", + &Hqp_SqpSolver::qp_update, this)); + _ifList.append(new If_Cmd("sqp_qp_solve", &Hqp_SqpSolver::qp_solve, this)); + _ifList.append(new If_Cmd("sqp_step", &Hqp_SqpSolver::step, this)); + _ifList.append(new If_Cmd("sqp_solve", &Hqp_SqpSolver::solve, this)); + _ifList.append(new If_Cmd("sqp_hela_restart", + &Hqp_SqpSolver::hela_restart, this)); + _ifList.append(new If_Cmd("sqp_qp_reinit_bd", + &Hqp_SqpSolver::qp_reinit_bd, this)); +} + +//-------------------------------------------------------------------------- +Hqp_SqpSolver::~Hqp_SqpSolver() +{ + delete _hela; + delete _solver; + if (_qp_Q_hot) + sp_free(_qp_Q_hot); + v_free(_x0); + v_free(_xk); + v_free(_d); + v_free(_y); + v_free(_z); + v_free(_dL); + v_free(_grd_L); +} + +//-------------------------------------------------------------------------- +void Hqp_SqpSolver::set_prg(Hqp_SqpProgram *prg) +{ + _prg = prg; + _solver->qp(prg->qp()); +} + +//-------------------------------------------------------------------------- +Real Hqp_SqpSolver::norm_inf(const Hqp_Program *qp) +{ + Real ret, tmp; + + if (qp->b->dim > 0) + ret = v_norm_inf(qp->b); + else + ret = 0.0; + + if (qp->d->dim > 0) { + tmp = -v_min(qp->d, NULL); + ret = max(ret, tmp); + } + + return ret; +} + +//-------------------------------------------------------------------------- +int Hqp_SqpSolver::init(IF_CMD_ARGS) +{ + if (!_prg) { + error(E_NULL, "Hqp_SqpSolver::init"); + } + + Hqp_Program *qp = _prg->qp(); + + if (!qp || !(VEC *)qp->c || !(VEC *)qp->b || !(VEC *)qp->d) { + error(E_NULL, "Hqp_SqpSolver::init"); + } + + _hela->setup(_prg); + + _solver->qp(qp); + _solver->init(); + + _x0 = v_resize(_x0, qp->c->dim); + _xk = v_resize(_xk, qp->c->dim); + _d = v_resize(_d, qp->c->dim); + _y = v_zero(v_resize(_y, qp->b->dim)); + _z = v_zero(v_resize(_z, qp->d->dim)); + _dL = v_zero(v_resize(_dL, qp->c->dim)); + _grd_L = v_zero(v_resize(_grd_L, qp->c->dim)); + + _iter = 0; + _inf_iters = 0; + _alpha = 1.0; + + _hot_started = false; + + return IF_OK; +} + +//-------------------------------------------------------------------------- +int Hqp_SqpSolver::qp_update(int, char *[], char **) +{ + if (!_prg) { + error(E_NULL, "Hqp_SqpSolver::qp_update"); + } + + Hqp_Program *qp = _prg->qp(); + + if (!qp || !(VEC *)qp->c || !(VEC *)qp->b || !(VEC *)qp->d) { + error(E_NULL, "Hqp_SqpSolver::qp_update"); + } + + if (_iter == 0) { + _prg->update(_y, _z); + + // init Hessian + _hela->init(_y, _z, _prg); + + // calculate x'Qx (use _xk just for temporal storage) + _xk = sp_mv_symmlt(qp->Q, _prg->x(), _xk); + _xQx = in_prod(_xk, _prg->x()); + _sQs = _xQx; + + _norm_inf = norm_inf(qp); + _norm_df = 0.0; + _norm_grd_L = v_norm_inf(qp->c); + _norm_x = v_norm_inf(_prg->x()); + _dphi = 0.0; + _phi = _prg->f(); + } + else { + /* + // Hessian update + if (_status != Hqp_Optimal || _alpha <= _min_alpha) { + // reinit Hessian + _prg->update(_y, _z); + _hela->init(_prg); + _grd_L = grd_L(qp, _grd_L); + } + else { + */ + _dL = grd_L(qp, _dL); + // update problem derivatives + if (!_hot_started) + _prg->update(_y, _z); + // update gradient of Lagrangian + _grd_L = grd_L(qp, _grd_L); + _dL = v_sub(_grd_L, _dL, _dL); + // update Hessian of Lagrangian + _hela->update(_d, _dL, _alpha, _prg); + + // calculate x'Qx (use _xk just for temporal storage) + _xk = sp_mv_symmlt(qp->Q, _prg->x(), _xk); + _xQx = in_prod(_xk, _prg->x()); + /* + } + */ + _norm_inf = norm_inf(qp); + _norm_df = fabs(_f_bak - _prg->f()); + _norm_grd_L = v_norm_inf(_grd_L); + } + + return IF_OK; +} + +//-------------------------------------------------------------------------- +int Hqp_SqpSolver::qp_solve(int, char *[], char **) +{ + if (!_prg) { + error(E_NULL, "Hqp_SqpSolver::qp_solve"); + } + + Hqp_Program *qp = _prg->qp(); + + if (!qp || !(VEC *)qp->c || !(VEC *)qp->b || !(VEC *)qp->d) { + error(E_NULL, "Hqp_SqpSolver::qp_update"); + } + + _f_bak = _prg->f(); + + if (_iter == 0) { + _solver->update(); + _solver->cold_start(); + } + else { + _solver->update(); + if (_status == Hqp_Optimal && _alpha > _min_alpha) + _solver->hot_start(); + else + _solver->cold_start(); + } + + _solver->solve(); + + // calculate s'Qs and ||s|| (use _xk just for temporal storage) + _xk = sp_mv_symmlt(qp->Q, qp->x, _xk); + _sQs = in_prod(_xk, qp->x); + _norm_dx = v_norm_inf(qp->x); + + return IF_OK; +} + +//-------------------------------------------------------------------------- +int Hqp_SqpSolver::hela_restart(int, char *[], char **) +{ + if (!_prg) { + error(E_NULL, "Hqp_SqpSolver::hela_restart"); + } + + sp_zero(_prg->qp()->Q); + _hela->init(_y, _z, _prg); + + //sp_ident(_prg->qp()->Q); + + //v_zero(_y); + //v_zero(_z); + + return IF_OK; +} + +//-------------------------------------------------------------------------- +int Hqp_SqpSolver::qp_reinit_bd(int, char *[], char **) +{ + if (!_prg) { + error(E_NULL, "Hqp_SqpSolver::qp_reinit_bd"); + } + + // reinit bounds in qp->b and qp->d + _prg->reinit_bd(); + _norm_inf = norm_inf(_prg->qp()); + + if (!_hot_started) { + // keep final Hessian of last cold solution + _qp_Q_hot = sp_copy3(_prg->qp()->Q, _qp_Q_hot); + _hot_started = true; + } + else { + // restore Hessian of last cold solution + sp_copy3(_qp_Q_hot, _prg->qp()->Q); + } + + return IF_OK; +} + +//-------------------------------------------------------------------------- +void Hqp_SqpSolver::feasible_vals() +{ + Hqp_Program *qp = _prg->qp(); + Real old_norm_inf = max(_norm_inf, _eps); + + v_zero(_y); + v_zero(_z); + + _x0 = v_copy(_prg->x(), _x0); + _alpha = 1.0; + + while (1) { + _d = sv_mlt(_alpha, qp->x, _d); + v_add(_x0, _d, _xk); + _prg->x(_xk); + _prg->update_fbd(); + _norm_inf = norm_inf(qp); + + if (is_finite(_prg->f()) && _norm_inf < 1e2 * old_norm_inf) + break; + + _alpha *= 0.5; + + if (_alpha <= _min_alpha) + break; + } +} + +//-------------------------------------------------------------------------- +int Hqp_SqpSolver::step(int, char *[], char **) +{ + if (!_prg) { + error(E_NULL, "Hqp_SqpSolver::step"); + } + + Hqp_Program *qp = _prg->qp(); + + if (!qp || !(VEC *)qp->c || !(VEC *)qp->b || !(VEC *)qp->d) { + error(E_NULL, "Hqp_SqpSolver::step"); + } + + _status = _solver->result(); + + //if (_status == Hqp_Suboptimal || _status == Hqp_Degenerate) + if (_status == Hqp_Suboptimal) + feasible_vals(); + else { + update_vals(); + if (_alpha <= _min_alpha) + feasible_vals(); + } + + // calculate _norm_x + _norm_x = v_norm_inf(_prg->x()); + _norm_inf = norm_inf(qp); + + _iter++; + + if (_status != Hqp_Optimal && _status != Hqp_Feasible) + _inf_iters++; + else + _inf_iters = 0; + + return IF_OK; +} + +//-------------------------------------------------------------------------- +int Hqp_SqpSolver::solve(int, char *[], char **ret) +{ + init(); + + do { + qp_update(); + if (_iter > 0 && _norm_inf < _eps) { + if (_iter >= _max_iters) break; + if (_norm_df < _eps) break; + if (_norm_dx < _eps) break; + if (_norm_grd_L < _eps) break; + //if (_status == Hqp_Insolvable) return IF_ERROR; + } + qp_solve(); + step(); + if (_alpha <= _min_alpha) break; + } while (1); + + if (_status != Hqp_Optimal) { + if (ret) + *ret = hqp_result_strings[_status]; + return IF_ERROR; + } + else + return IF_OK; +} + +//-------------------------------------------------------------------------- +VEC *Hqp_SqpSolver::grd_L(const Hqp_Program *qp, VEC *out) +{ + int n = qp->Q->m; + + if (!out || (int)out->dim != n) { + out = v_resize(out, n); + } + + // calculate gradient of Lagrangian + v_zero(out); + sp_vm_mltadd(out, _y, qp->A, 1.0, out); + sp_vm_mltadd(out, _z, qp->C, 1.0, out); + v_sub(qp->c, out, out); + + return out; +} + +//========================================================================== diff --git a/hqp/Hqp_SqpSolver.h b/hqp/Hqp_SqpSolver.h new file mode 100644 index 0000000..78a971e --- /dev/null +++ b/hqp/Hqp_SqpSolver.h @@ -0,0 +1,123 @@ +/* + * Hqp_SqpSolver.h -- + * - base class for solving nonlinear programs with + * sequential quadratic programming + * + * rf, 6/6/94 + * + * rf, 12/23/99 + * - extended member access methods + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_SqpSolver_H +#define Hqp_SqpSolver_H + +#include +#include +#include + +#include "Hqp_impl.h" + +class Hqp_Program; +class Hqp_Solver; +class Hqp_SqpProgram; +class Hqp_HL; + +IF_BASE_DECLARE(Hqp_SqpSolver); + +class Hqp_SqpSolver { + + protected: + If_List _ifList; + + Hqp_SqpProgram *_prg; // program to work with + + Hqp_Solver *_solver; + Hqp_HL *_hela; + VEC *_x0; // for line search + VEC *_xk; // for line search + VEC *_d; // x^(k+1) - x^k (including _alpha) + VEC *_y; // multipiers for equality constraints + VEC *_z; // multipiers for inequality constraints + VEC *_dL; // grd_L^(k+1) - grd_L^k + VEC *_grd_L; + Real _phi; // current value of penalty function + Real _dphi; // (descending) direction of penalty function + Real _sQs; + Real _xQx; + + int _iter; + int _max_iters; + int _inf_iters; + int _max_inf_iters; + Real _eps; + Real _norm_dx; + Real _norm_x; + Real _norm_inf; // infeasibility norm + Real _norm_grd_L; + Real _norm_df; // change of objective + Real _f_bak; // objective of last iterate respectively + Hqp_Result _status; + bool _logging; // print status messages + + Real _alpha; // step length + Real _min_alpha; // step length, that identifies a stall + + bool _hot_started; // indicate a hot start + SPMAT *_qp_Q_hot; // backing store Hessian of last cold start + + virtual void feasible_vals();// update_xyz for suboptimal + virtual void update_vals()=0;// update _alpha,_d,_y,_z, and prg->x,f,b,d + virtual VEC *grd_L(const Hqp_Program *, VEC *out); + Real norm_inf(const Hqp_Program *); + + public: + Hqp_SqpSolver(); + virtual ~Hqp_SqpSolver(); + + Hqp_SqpProgram *prg() {return _prg;} + void set_prg(Hqp_SqpProgram *); + + virtual int init(IF_DEF_ARGS); + virtual int qp_update(IF_DEF_ARGS); + virtual int qp_solve(IF_DEF_ARGS); + virtual int step(IF_DEF_ARGS); + virtual int hela_restart(IF_DEF_ARGS); + virtual int qp_reinit_bd(IF_DEF_ARGS); + + virtual int solve(IF_DEF_ARGS); + + virtual char *name()=0; + + // member access methods + + int iter() {return _iter;} + int max_iters() {return _max_iters;} + void set_max_iters(int val) {_max_iters = val;} + + Real norm_dx() {return _norm_dx;} + Real norm_inf() {return _norm_inf;} + Real norm_grd_L() {return _norm_grd_L;} +}; + + +#endif diff --git a/hqp/Hqp_Structure.C b/hqp/Hqp_Structure.C new file mode 100644 index 0000000..47ea57b --- /dev/null +++ b/hqp/Hqp_Structure.C @@ -0,0 +1,524 @@ +/* + * Hqp_Structure.C + * + * rf, 5/19/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#include "Hqp_Structure.h" +#include "Hqp_Program.h" + + +//------------------------------------------------------------------------ +// some static stuff for sorting + +static int *_criteria; +static int *_criteria2; +static int _compare(const int *p1, const int *p2) +{ + int ret; + ret = _criteria[*p1] - _criteria[*p2]; + if (ret == 0) { + ret = _criteria2[*p1] - _criteria2[*p2]; + } + return ret; +} + +//------------------------------------------------------------------------ +Hqp_Structure::Hqp_Structure() +{ + _n = 0; + _nentries = 0; + _neigh_size = 0; + _order = PNULL; +} + +//------------------------------------------------------------------------ +Hqp_Structure::~Hqp_Structure() +{ + if (_n > 0) { + delete [] _neigh_start; + delete [] _degree; + } + if (_neigh_size > 0) { + delete [] _neighbours; + } + px_free(_order); +} + +//------------------------------------------------------------------------ +void Hqp_Structure::realloc(int n, int neigh_size) +{ + assert (n > 0 && neigh_size > 0); + + if (n != _n) { + if (_n > 0) { + delete [] _neigh_start; + delete [] _degree; + } + _n = n; + _neigh_start = new int [n+1]; + _degree = new int [n]; + _order = px_resize(_order, n); + } + + if (neigh_size != _neigh_size) { + if (_neigh_size > 0) { + delete [] _neighbours; + } + _neigh_size = neigh_size; + _neighbours = new int [neigh_size]; + } +} + +//------------------------------------------------------------------------ +void Hqp_Structure::neigh_grow() +{ + int cur_size = _neigh_size; + int *cur_neigh = _neighbours; + + _neigh_size += _neigh_size / 2; + _neighbours = new int [_neigh_size]; + for (int i=0; i 1) + qsort( (void *)(_neighbours + _neigh_start[i]), + nneigh, sizeof(int), + (int (*)(const void *, const void *))_compare); + } +} + +//------------------------------------------------------------------------ +int Hqp_Structure::add_row(const SPMAT *mat, int i, int node, int offs) +{ + int j_idx, jend; + const row_elt *elt; + int neigh_idx = _neigh_start[node+1]; + + elt = mat->row[i].elt; + jend = mat->row[i].len; + for (j_idx=0; j_idxcol + offs != node) { + if (neigh_idx == _neigh_size) + neigh_grow(); + _neighbours[neigh_idx++] = elt->col + offs; + _degree[node] ++; + } + } + _neigh_start[node+1] = neigh_idx; + + return jend; +} +#ifdef SPARSE_COL_ACCESS +//------------------------------------------------------------------------ +int Hqp_Structure::add_col(const SPMAT *mat, int j, int node, int offs) +{ + int i, j_idx; + const row_elt *elt; + int neigh_idx = _neigh_start[node+1]; + int nadd = 0; + + i = mat->start_row[j]; + j_idx = mat->start_idx[j]; + while (i >= 0) { + elt = &(mat->row[i].elt[j_idx]); + if (i + offs != node) { + if (neigh_idx == _neigh_size) + neigh_grow(); + _neighbours[neigh_idx++] = i + offs; + _degree[node] ++; + } + i = elt->nxt_row; + j_idx = elt->nxt_idx; + nadd++; + } + _neigh_start[node+1] = neigh_idx; + + return nadd; +} +#endif +//------------------------------------------------------------------------ +void Hqp_Structure::init_spmat(const SPMAT *M) +{ + int i, n; + + // reallocate data + + n = M->m; + realloc(n, 10*n); + + // scan M's sparsity structure (M should be symmetric) + + _nentries = 0; + _neigh_start[0] = 0; + for (i=0; im == Q->n && Q->m == A->n && Q->m == C->n); + + if (!A->flag_col) + sp_col_access(A); + if (!C->flag_col) + sp_col_access(C); + + // reallocate data + + n = Q->m + A->m + C->m; + realloc(n, 10*n); + + // + // scan sparsity structure + // + + _nentries = C->m; // values of W/Z that are not looked for + + // submatrix Q A' C' + + node = 0; + _neigh_start[0] = 0; + iend = Q->m; + for (i=0; in); + _nentries += add_col(C, i, node, Q->n + A->m); + } + + // matrix A by rows + + iend = A->m; + for (i=0; im; + for (i=0; im == Q->n && Q->m == A->n); + + if (!A->flag_col) + sp_col_access(A); + + // reallocate data + + n = Q->m + A->m; + realloc(n, 10*n); + + // + // scan sparsity structure + // + + _nentries = 0; + + // submatrix Q A' + + node = 0; + _neigh_start[0] = 0; + iend = Q->m; + for (i=0; in); + } + + // matrix A by rows + + iend = A->m; + for (i=0; ipe; + int l_begin, l_end; + int nlevels, nlevels_old; + int i, j, jend, k, kend; + int min_deg; + int cluster_start; + + _criteria = deg; + _criteria2 = deg2; + + for (i=0; i<_n; i++) + glob_marks[i] = 1; + root = 0; + count = 0; + + while (root < _n) { + + nlevels = 0; + cluster_start = count; + + do { /* ... while (nlevels > nlevels_old) */ + + // find level structure for current root node + + count = cluster_start; + + for (i=0; i<_n; i++) { + marks[i] = glob_marks[i]; + deg[i] = _degree[i]; + } + nlevels_old = nlevels; + nlevels = 0; + l_begin = count; + l_end = count; + levels[count++] = root; // add root node + marks[root] = 0; // unmark root node + kend = _neigh_start[root+1]; // decrement degree of neighbours + for (k=_neigh_start[root]; k l_end) */ + + // add nodes for next level + + l_begin = l_end; + l_end = count; + nlevels ++; + for (i=l_begin; i 1) { + for (k=l_end; k l_end); + + if (nlevels_old > nlevels) + fprintf(stderr, "Hqp_Structure::order_rcm: Levels decreased!\n"); + + // choice of the node with smallest degree in the last level + // as root for next iteration + root = levels[l_begin]; + min_deg = _degree[root]; + for (i=l_begin+1; i nlevels_old); + + root = _n; + for (i=0; i<_n; i++) { + glob_marks[i] = marks[i]; + if (marks[i]) + root = i; + } + } + px_inv(_order, _order); + + // _order[i] says, where to put row/col i into reordered matrix + + // revert _order + for (i=0; i<_n; i++) + _order->pe[i] = _n - _order->pe[i] - 1; + + delete [] marks; + delete [] glob_marks; + delete [] deg; + delete [] deg2; +} + +//------------------------------------------------------------------------ +PERM *Hqp_Structure::px_get(PERM *px) +{ + px = px_copy(_order, px); + return px; +} + +//------------------------------------------------------------------------ +const IVEC *Hqp_Structure::neighbours(int node) +{ + assert(node < _n); + + _neigh_out.ive = _neighbours + _neigh_start[node]; + _neigh_out.dim = _neigh_start[node+1] - _neigh_start[node]; + _neigh_out.max_dim = 0; + + return &_neigh_out; +} + +//------------------------------------------------------------------------ +const Hqp_BandSize *Hqp_Structure::bd_size() +{ + int i, i_idx; + int j_idx, jend; + int min_neigh, max_neigh; + int lb, ub; + int node, dist; + + // determine band size according current ordering + + lb = ub = 0; + for (i_idx=0; i_idx<_n; i_idx++) { + i = _order->pe[i_idx]; + min_neigh = max_neigh = i; + jend = _neigh_start[i_idx+1]; + for (j_idx=_neigh_start[i_idx]; j_idxpe[_neighbours[j_idx]]; + if (node < min_neigh) + min_neigh = node; + else if (node > max_neigh) + max_neigh = node; + } + + dist = i - min_neigh; + if (dist > lb) + lb = dist; + + dist = max_neigh - i; + if (dist > ub) + ub = dist; + } + + // fill and return _bandSize + + _bandSize.lb = lb; + _bandSize.ub = ub; + _bandSize.n = _n; + + return &_bandSize; +} diff --git a/hqp/Hqp_Structure.h b/hqp/Hqp_Structure.h new file mode 100644 index 0000000..6f901ba --- /dev/null +++ b/hqp/Hqp_Structure.h @@ -0,0 +1,92 @@ +/* + * Hqp_Structure.h -- + * - express sparsity structure of a matrix for permutations + * - reference: Weissinger: Sp"arlich besetzte Gleichungssysteme + * + * rf, 5/19/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_Structure_H +#define Hqp_Structure_H + +#include "Hqp_impl.h" + +class Hqp_Program; + +class Hqp_BandSize { + + public: + + int lb; // number of bands below diagonal + int ub; // number of bands above diagonal + int n; // number of rows (cols) +}; + +class Hqp_Structure { + + protected: + + // buffer for returning by methods + Hqp_BandSize _bandSize; + IVEC _neigh_out; + + // data to represent sparsity structure + int _nentries; + int _n; // dimension (of symmetric matrix) + int *_neighbours; // list of neighbours of all nodes + int _neigh_size; // size of _neighbours + int *_neigh_start; // offsets into _neighbors of all nodes + int *_degree; // degrees of all nodes + PERM *_order; // hold ordering + + int add_row(const SPMAT *, int i, int node, int offs=0); + int add_col(const SPMAT *, int j, int node, int offs=0); + + void neigh_grow(); + void neigh_sort(); + + void realloc(int n, int neigh_size); + + public: + + Hqp_Structure(); + ~Hqp_Structure(); + + // initializing +#ifdef SPARSE_COL_ACCESS + void init_QAC(const SPMAT *Q, const SPMAT *A, const SPMAT *C); + void init_QA(const SPMAT *Q, const SPMAT *A); +#endif + void init_spmat(const SPMAT *); + + // performing actions + void order_rcm(); + + // access to results + int nentries() {return _nentries;} + PERM *px_get(PERM *px=PNULL); + const IVEC *neighbours(int node); + const Hqp_BandSize *bd_size(); // return read only data +}; + + +#endif diff --git a/hqp/Hqp_impl.C b/hqp/Hqp_impl.C new file mode 100644 index 0000000..5a9e416 --- /dev/null +++ b/hqp/Hqp_impl.C @@ -0,0 +1,40 @@ +/* + * Hqp_impl.C -- definitions + * + * rf, 5/29/94 + * + * rf, 2/12/97 + * modified result strings + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include "Hqp_impl.h" + +char *hqp_result_strings[] = { + "optimal", + "feasible", + "infeasible", + "suboptimal", + "degenerate" +}; + + +//========================================================================= diff --git a/hqp/Hqp_impl.h b/hqp/Hqp_impl.h new file mode 100644 index 0000000..1622e54 --- /dev/null +++ b/hqp/Hqp_impl.h @@ -0,0 +1,55 @@ +/* + * Hqp_impl.h -- declarations for HQP (Huge Quadratic Programming) + * + * rf, 5/28/94 + * + * rf, 2/12/97 + * new result Hqp_Degenerate for singular matrix errors + * no result Hqp_Insolvable anymore as this can't be decited on QP-level + * + * rf, 11/01/00 + * distinguish between Hqp_impl.h (for internal use) + * and Hqp.h (for external use) + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_impl_H +#define Hqp_impl_H + +#include "Hqp.h" + +/** return HQP version string */ +extern const char *hqp_version(); + +/** possible results of QP solver */ +enum Hqp_Result { + Hqp_Optimal = 0, + Hqp_Feasible, + Hqp_Infeasible, + Hqp_Suboptimal, + Hqp_Degenerate +}; + +/** array of result strings for Hqp_Result */ +extern char *hqp_result_strings[]; + + +#endif diff --git a/hqp/Makefile b/hqp/Makefile new file mode 100644 index 0000000..8674ed9 --- /dev/null +++ b/hqp/Makefile @@ -0,0 +1,75 @@ +# Makefile for libhqp +# ("makedepend" is used for depencies) + +include ../makedirs +include ../makedefs + +O = $(OBJ_SUFFIX) + +CCDEFS = $(MES_INCDIR) $(TCL_INCDIR) $(IF_INCDIR) $(ASCEND_INCDIR) \ + $(HQP_INCDIR) $(HQP_DEFS) + +SRCS = Hqp_Init.C \ + Hqp.C \ + sprcm.C \ + Meschach.C \ + spBKP.C \ + Hqp_impl.C \ + Hqp_Program.C \ + Hqp_Solver.C \ + Hqp_Client.C \ + Hqp_IpsFranke.C \ + Hqp_IpsMehrotra.C \ + Hqp_IpMatrix.C \ + Hqp_IpSpBKP.C \ + Hqp_IpRedSpBKP.C \ + Hqp_IpLQDOCP.C \ + t_mesch.C \ + meschext_ea.C \ + Hqp_IpSpSC.C \ + meschext_hl.C \ + Hqp_SqpSolver.C \ + Hqp_SqpPowell.C \ + Hqp_SqpSchittkowski.C \ + Hqp_HL.C \ + Hqp_HL_Gerschgorin.C \ + Hqp_HL_DScale.C \ + Hqp_HL_BFGS.C \ + Hqp_HL_SparseBFGS.C \ + Hqp_SqpProgram.C \ + Hqp_Docp.C \ + $(CUTE_SRCS) \ + $(ASCEND_SRCS) + +OBJS = $(SRCS:.C=$O) hqp_solve$O +# add own qsort to HQP sources for comparison on different platforms +#OBJS = $(SRCS:.C=$O) qsort$O hqp_solve$O + +LIBRARY = hqp + +all: lib + +lib: $(OBJS) Makefile + rm -f $(LIB_PREFIX)$(LIBRARY)$(MKLIB_SUFFIX) + $(LD)$(LIB_PREFIX)$(LIBRARY)$(MKLIB_SUFFIX) $(OBJS) \ + ../meschach/*$O ../iftcl/*$O $(HQP_MACH_OBJS) + +hqp_solve.c: tpc hqp_solve.tcl + ./tpc -ts 80 -o hqp_solve.c hqp_solve.tcl + +tpc: + $(CC) -o tpc tpc.c + +.C$O: + $(CXX) -c $(CXXFLAGS) $(CCDEFS) $< + +.c$O: + $(CC) -c $(CFLAGS) $(CCDEFS) $< + +depend: + makedepend -- $(CCDEFS) -- $(SRCS) + +clean: + rm -f tpc$(EXE_SUFFIX) hqp_solve.c *.o *.obj $(LIB_PREFIX)hqp.* *~ + +# DO NOT DELETE THIS LINE -- make depend depends on it. diff --git a/hqp/Meschach.C b/hqp/Meschach.C new file mode 100644 index 0000000..1616860 --- /dev/null +++ b/hqp/Meschach.C @@ -0,0 +1,1084 @@ +/* + * Meschach.C -- definitions + * + * rf, 8/18/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include "Meschach.h" + +#define SPLU_MOD + +#define SPROW_IDX(r,k) \ + ((k < r->elt[0].col) ? -2 : \ + ((k > r->elt[r->len-1].col) ? -(r->len+2) : sprow_idx(r,k))) + +/* + * spLUfactor2 -- derived from spLUfactor, faster for banded matrices + * - makro to avoid many binary searches in sprow_idx (+25%) + * - no Markowitz strategy as A is globaly permuted (+15%) + * - additional continue-check for elimination (+10%) + */ +SPMAT *spLUfactor2(SPMAT *A, PERM *px) +{ + int i, best_i, k, idx, m, n; + SPROW *r, *r_piv, tmp_row; + static SPROW *merge = (SPROW *)NULL; + Real max_val, tmp; + static VEC *col_vals=VNULL; +#ifdef SPLU_MOD + int piv_max_col; +#else + int len, best_len; + double alpha; + alpha = 0.1; +#endif + if ( ! A || ! px ) + error(E_NULL,"spLUfctr"); +#ifndef SPLU_MOD + if ( alpha <= 0.0 || alpha > 1.0 ) + error(E_RANGE,"alpha in spLUfctr"); +#endif + if ( (int)px->size <= A->m ) + px = px_resize(px,A->m); + px_ident(px); + col_vals = v_resize(col_vals,A->m); + MEM_STAT_REG(col_vals,TYPE_VEC); + + m = A->m; n = A->n; +#ifndef SPLU_MOD + if ( ! A->flag_col ) + sp_col_access(A); + if ( ! A->flag_diag ) + sp_diag_access(A); +#endif + A->flag_col = A->flag_diag = FALSE; + if ( ! merge ) { + merge = sprow_get(20); + MEM_STAT_REG(merge,TYPE_SPROW); + } + + for ( k = 0; k < n; k++ ) + { + /* find pivot row/element for partial pivoting */ + + /* get first row with a non-zero entry in the k-th column */ + max_val = 0.0; + best_i = k; + for ( i = k; i < m; i++ ) + { + r = &(A->row[i]); + idx = SPROW_IDX(r,k); + if ( idx < 0 ) + tmp = 0.0; + else { + tmp = r->elt[idx].val; + if ( fabs(tmp) > max_val ) { + max_val = fabs(tmp); + best_i = i; + } + } + col_vals->ve[i] = tmp; + } + + if ( max_val == 0.0 ) + continue; +#ifndef SPLU_MOD + best_len = n+1; /* only if no possibilities */ + best_i = -1; + for ( i = k; i < m; i++ ) + { + tmp = fabs(col_vals->ve[i]); + if ( tmp == 0.0 ) + continue; + if ( tmp >= alpha*max_val ) + { + r = &(A->row[i]); + idx = SPROW_IDX(r,k); + len = (r->len) - idx; + if ( len < best_len ) + { + best_len = len; + best_i = i; + } + } + } +#endif + /* swap row #best_i with row #k */ + MEM_COPY(&(A->row[best_i]),&tmp_row,sizeof(SPROW)); + MEM_COPY(&(A->row[k]),&(A->row[best_i]),sizeof(SPROW)); + MEM_COPY(&tmp_row,&(A->row[k]),sizeof(SPROW)); + /* swap col_vals entries */ + tmp = col_vals->ve[best_i]; + col_vals->ve[best_i] = col_vals->ve[k]; + col_vals->ve[k] = tmp; + px_transp(px,k,best_i); + + r_piv = &(A->row[k]); +#ifdef SPLU_MOD + piv_max_col = r_piv->elt[r_piv->len - 1].col; +#endif + for ( i = k+1; i < n; i++ ) + { + r = &(A->row[i]); +#ifdef SPLU_MOD + if (r->len == 0 || piv_max_col < r->elt[0].col) + continue; +#endif + /* compute and set multiplier */ + tmp = col_vals->ve[i]/col_vals->ve[k]; + if ( tmp != 0.0 ) + sp_set_val(A,i,k,tmp); + else + continue; + + /* perform row operations */ + merge->len = 0; + sprow_mltadd(r,r_piv,-tmp,k+1,merge,TYPE_SPROW); + idx = SPROW_IDX(r,k+1); + if ( idx < 0 ) + idx = -(idx+2); + /* see if r needs expanding */ + if ( r->maxlen < idx + merge->len ) + sprow_xpd(r,idx+merge->len,TYPE_SPMAT); + r->len = idx+merge->len; + MEM_COPY((char *)(merge->elt),(char *)&(r->elt[idx]), + merge->len*sizeof(row_elt)); + } + } + + return A; +} + +//-------------------------------------------------------------------------- +Real sprow_inprod(const SPROW *r1, const VEC *inner, const SPROW *r2) +{ + Real sum; + int j_idx1, j_idx2, j1, j2; + int len1, len2; + row_elt *elt1, *elt2; + + j_idx1=0; + j_idx2=0; + len1 = r1->len; + len2 = r2->len; + elt1 = r1->elt; + elt2 = r2->elt; + j1 = elt1->col; + j2 = elt2->col; + sum = 0.0; + while (j_idx1 < len1 && j_idx2 < len2) { + if (j1 < j2) { + j_idx1 ++; + elt1 ++; + j1 = elt1->col; + } + else if (j1 > j2) { + j_idx2 ++; + elt2 ++; + j2 = elt2->col; + } + else { + sum += elt1->val * inner->ve[j1] * elt2->val; + + j_idx1 ++; + elt1 ++; + j1 = elt1->col; + + j_idx2 ++; + elt2 ++; + j2 = elt2->col; + } + } + + return sum; +} + +//------------------------------------------------------------------------- +void sprow_zero(SPROW *row) +{ + int i, len = row->len; + row_elt *elt = row->elt; + + for (i = 0; i < len; i++, elt++) + elt->val = 0.0; +} + +//------------------------------------------------------------------------- +VEC *v_part(VEC *v, int offs, int dim, VEC *head) +{ + if (!v) + error(E_NULL,"v_part"); + if ((int)v->dim < offs + dim) + error(E_SIZES,"v_part"); + + head->dim = dim; + head->max_dim = 0; + head->ve = v->ve + offs; + + return head; +} + +//------------------------------------------------------------------------- +VEC *v_set(VEC *v, Real val) +{ + int i, i_end; + Real *ve; + + if (v != VNULL) { + ve = v->ve; + i_end = v->dim; + for (i=0; idim = nel; + } else { + if (v->dim + nel <= v->max_dim) + v->dim += nel; + else { + vbak = v_copy(v, VNULL); + v_resize(v, v->dim + granul); + v_copy(vbak, v_part(v, 0, vbak->dim, &vv)); + v->dim = vbak->dim + nel; + v_free(vbak); + } + } + + return v; +} + +//------------------------------------------------------------------------- +IVEC *iv_part(IVEC *iv, int offs, int dim, IVEC *head) +{ + if (!iv) + error(E_NULL,"iv_part"); + if ((int)iv->dim < offs + dim) + error(E_SIZES,"iv_part"); + + head->dim = dim; + head->max_dim = 0; + head->ive = iv->ive + offs; + + return head; +} + +//------------------------------------------------------------------------- +IVEC *iv_set(IVEC *iv, int val) +{ + int i, i_end; + int *ive; + + if (iv != IVNULL) { + ive = iv->ive; + i_end = iv->dim; + for (i=0; idim = nel; + } else { + if (iv->dim + nel <= iv->max_dim) + iv->dim += nel; + else { + ivbak = iv_copy(iv, IVNULL); + iv_resize(iv, iv->dim + granul); + iv_copy(ivbak, iv_part(iv, 0, ivbak->dim, &ivv)); + iv->dim = ivbak->dim + nel; + iv_free(ivbak); + } + } + + return iv; +} + +//------------------------------------------------------------------------- +VEC *bd_mv_mlt(const BAND *A, const VEC *x, VEC *out) +{ + int i, j, j_end, k; + int start_idx, end_idx; + int n, m, lb, ub; + Real **A_me; + Real *x_ve; + Real sum; + + if (!A || !x) + error(E_NULL,"bd_mv_mlt"); + if (x->dim != A->mat->n) + error(E_SIZES,"bd_mv_mlt"); + if (!out || out->dim != A->mat->n) + out = v_resize(out, A->mat->n); + if (out == x) + error(E_INSITU,"bd_mv_mlt"); + + n = A->mat->n; + m = A->mat->m; + lb = A->lb; + ub = A->ub; + A_me = A->mat->me; + start_idx = lb; + end_idx = m + n-1 - ub; + for (i=0; ive + k; + sum = 0.0; + for (; jve[i] = sum; + } + + return out; +} + +//------------------------------------------------------------------------- +// m_mltadd -- out = m1 + alpha*m2 +// +MAT *m_mltadd(const MAT *m1, const MAT *m2, Real alpha, MAT *out) +{ + int i, n, m; + + if (!m1 || !m2) + error(E_NULL,"m_mltadd"); + if (m2 == out) + error(E_INSITU,"m_mltadd"); + if (m1->m != m2->m || m1->n != m2->n) + error(E_SIZES,"m_mltadd"); + + if (out != m1) + out = m_copy((MAT *)m1, out); + + m = out->m; + n = out->n; + for (i=0; ime[i], m2->me[i], alpha, n); + } + + return out; +} + +//------------------------------------------------------------------------- +SPMAT *sp_copy3(const SPMAT *src, SPMAT *dst) +{ + SPROW *rs, *rd; + int i, n, m; + + if (!src) + error(E_NULL, "sp_copy3"); + n = src->n; + m = src->m; + if (!dst || dst->n != n || dst->m != m) + dst = sp_resize(dst, m, n); + + rd = dst->row; + rs = src->row; + for (i=0; imaxlen < rs->len) + sprow_resize(rd, rs->len, TYPE_SPMAT); + rd->len = rs->len; + rd->diag = rs->diag; + MEM_COPY(rs->elt, rd->elt, rs->len * sizeof(row_elt)); + } + + dst->flag_col = src->flag_col; + dst->flag_diag = src->flag_diag; + + return dst; +} + +//------------------------------------------------------------------------- +// sp_update_val: +// set an entry of a sparse matrix that should already exist +// return 0 if existing entry updated +// 1 if new entry allocated +// +int sp_update_val(SPMAT *A, int i, int j, Real val) +{ + SPROW *row; + int idx; + + if ( A == SMNULL ) + error(E_NULL,"sp_update_val"); + if ( i < 0 || i >= A->m || j < 0 || j >= A->n ) + error(E_SIZES,"sp_update_val"); + + row = A->row+i; + idx = sprow_idx(row, j); + if ( idx >= 0 ) { + row->elt[idx].val = val; + return 0; + } + else { + // allocate new entry + sp_set_val(A, i, j, val); + return -1; + } +} + +//--------------------------------------------------------------------------- +// sp_insert_mrow: +// insert all non-zero entries of a dense matrix--row into a sparse matrix +// +void sp_insert_mrow(SPMAT *dst, int i_offs, int j_offs, const MAT *src, int i) +{ + int j, jend = src->n; + double val; + + if (!dst || !src) + error(E_NULL, "sp_insert_mrow"); + if (i < 0 || i >= (int)src->m) + error(E_BOUNDS, "sp_insert_mrow"); + + for(j=0; jme[i][j]; + if (val != 0.0) + sp_set_val(dst, i+i_offs, j+j_offs, val); + } +} + +//--------------------------------------------------------------------------- +// sp_update_mrow: +// update entries of a sparse matrix with elements of a dense matrix--row +// +void sp_update_mrow(SPMAT *dst, int i_offs, int j_offs, const MAT *src, int i) +{ + SPROW *row; + int j, j_idx, j_end; + + if (!dst || !src) + error(E_NULL, "sp_update_mrow"); + if (i < 0 || i >= (int)src->m) + error(E_BOUNDS, "sp_update_mrow"); + + j_end = src->n; + row = dst->row + i_offs + i; + j_idx = sprow_idx(row, j_offs); + if (j_idx < 0) { + if (j_idx == -1) + error(E_BOUNDS,"sp_update_mrow"); + j_idx = -(j_idx + 2); + } + while (j_idx < row->len) { + j = row->elt[j_idx].col - j_offs; + if (j >= j_end) + break; + row->elt[j_idx].val = src->me[i][j]; + j_idx++; + } +} + +//---------------------------------------------------------------------------- +void sp_extract_mrow(const SPMAT *src, int i_offs, int j_offs, MAT *dst, int i) +{ + SPROW *row; + int j, j_end, j_idx; + + if (!src || !dst) + error(E_NULL, "sp_extract_mrow"); + if (i < 0 || i >= (int)dst->m) + error(E_BOUNDS, "sp_extract_mrow"); + + j_end = dst->n; + for (j=0; jme[i][j] = 0; + + row = src->row + i_offs + i; + j_idx = sprow_idx(row, j_offs); + if (j_idx < 0) { + if (j_idx == -1) + error(E_BOUNDS,"sp_extract_mrow"); + j_idx = -(j_idx + 2); + } + while (j_idx < row->len) { + j = row->elt[j_idx].col - j_offs; + if (j >= j_end) + break; + dst->me[i][j] = row->elt[j_idx].val; + j_idx++; + } +} + +//-------------------------------------------------------------------------- +// sp_insert_mat: +// insert all non-zero entries of a dense matrix into a sparse matrix +// +void sp_insert_mat(SPMAT *dst, int i_offs, int j_offs, const MAT *src) +{ + int i, iend = src->m; + int j, jend = src->n; + double val; + + for (i=0; ime[i][j]; + if (val != 0.0) + sp_set_val(dst, i+i_offs, j+j_offs, val); + } +} + +//-------------------------------------------------------------------------- +// symsp_insert_symmat: +// insert upper diagonal non-zero entries of a symmetric dense matrix +// into a symmetric sparse matrix +// +void symsp_insert_symmat(SPMAT *dst, int offs, const MAT *src) +{ + int i, iend = src->m; + int j, jend = src->n; + double val; + + for (i = 0; i < iend; i++) + for(j = i; j < jend; j++) { + val = src->me[i][j]; + if (val != 0.0) + sp_set_val(dst, i + offs, j + offs, val); + } +} + +//-------------------------------------------------------------------------- +// sp_update_mat: +// update entries of a sparse matrix with elements of a dense matrix +// +void sp_update_mat(SPMAT *dst, int i_offs, int j_offs, const MAT *src) +{ + SPROW *row; + int i, i_end; + int j, j_idx, j_end; + + i_end = src->m; + j_end = src->n; + for(i=0; irow + i_offs + i; + j_idx = sprow_idx(row, j_offs); + if (j_idx < 0) { + if (j_idx == -1) + error(E_BOUNDS,"sp_update_mat"); + j_idx = -(j_idx + 2); + } + while (j_idx < row->len) { + j = row->elt[j_idx].col - j_offs; + if (j >= j_end) + break; + row->elt[j_idx].val = src->me[i][j]; + j_idx++; + } + } +} + +//------------------------------------------------------------------------- +void sp_extract_mat(const SPMAT *src, int i_offs, int j_offs, MAT *dst) +{ + SPROW *row; + int i, j; + int i_end, j_end, j_idx; + + m_zero(dst); + + i_end = dst->m; + j_end = dst->n; + for (i=0; irow + i_offs + i; + j_idx = sprow_idx(row, j_offs); + if (j_idx < 0) { + if (j_idx == -1) + error(E_BOUNDS,"sp_extract_mat"); + j_idx = -(j_idx + 2); + } + while (j_idx < row->len) { + j = row->elt[j_idx].col - j_offs; + if (j >= j_end) + break; + dst->me[i][j] = row->elt[j_idx].val; + j_idx++; + } + } +} + +//------------------------------------------------------------------------- +void symsp_extract_mat(const SPMAT *src, int offs, MAT *dst) +{ + SPROW *row; + Real val; + int i, j; + int i_end, j_end, j_idx; + + m_zero(dst); + + i_end = dst->m; + j_end = dst->n; + for (i = 0; i < i_end; i++) { + row = src->row + offs + i; + j_idx = sprow_idx(row, offs + i); + if (j_idx < 0) { + if (j_idx == -1) + error(E_BOUNDS,"sp_extract_mat"); + j_idx = -(j_idx + 2); + } + while (j_idx < row->len) { + j = row->elt[j_idx].col - offs; + if (j >= j_end) + break; + val = row->elt[j_idx].val; + dst->me[i][j] = val; + if (i != j) + dst->me[j][i] = val; + j_idx++; + } + } +} + +//------------------------------------------------------------------------- +SPMAT *sp_ident(SPMAT *A) +{ + int i; + int i_end = min(A->n, A->m); + + sp_zero(A); + for (i=0; im; i++) { + elt = A->row[i].elt; + len = A->row[i].len; + rsum = 0.0; + for (idx = 0; idx < len; idx++, elt++) + rsum += fabs((*elt).val); + norm = max(norm, rsum); + } + + return norm; +} + +/* sp_ones -- set all the (represented) elements of a sparse matrix to 1.0 */ +SPMAT *sp_ones( SPMAT *A) +{ + int i, idx, len; + row_elt *elt; + + if ( ! A ) + error(E_NULL,"sp_ones"); + + for ( i = 0; i < A->m; i++ ) + { + elt = A->row[i].elt; + len = A->row[i].len; + for ( idx = 0; idx < len; idx++ ) + (*elt++).val = 1.0; + } + + return A; +} + +/* + * sp_transp: + * -- build the transpose of sparse matrix A in T + * -- return T + * -- routine may not work in-situ + */ +SPMAT *sp_transp(const SPMAT *A, SPMAT *T) +{ + int n, m; + int i, j_idx; + int slen, dlen; + row_elt *selt, *delt; + SPROW *srow, *drow; + + if (!A) + error(E_NULL, "sp_transp"); + if (A == T) + error(E_INSITU, "sp_transp"); + + n = A->n; + m = A->m; + + if (!T) + T = sp_copy(A); + if (T->m != n || T->n != m) + T = sp_resize(T, n, m); + + for (i=0; irow[i].len = 0; + T->flag_col = 0; + T->flag_diag = 0; + + for (i=0; irow + i; + slen = srow->len; + selt = srow->elt; + for (j_idx = 0; j_idx < slen; j_idx++, selt++) { + drow = T->row + selt->col; + dlen = drow->len; +#if 1 + if (dlen == drow->maxlen) { + drow = sprow_xpd(drow, (3*dlen)/2, TYPE_SPMAT); + drow->len = dlen; + } +#else + if (dlen == drow->maxlen) { + // drow = sprow_xpd(drow, (3*dlen)/2, TYPE_SPMAT); + drow = sprow_xpd(drow, dlen+10, TYPE_SPMAT); + drow->len = dlen; + } +#endif + delt = drow->elt + dlen; + delt->val = selt->val; + delt->col = i; + drow->len ++; + } + } + + return T; +} + +/* sp_mv_mltadd -- sparse matrix/dense vector multiply and add + * -- returns out == v1 + alpha*A*v2 + * -- if out==NULL on entry then the result vector is created + */ +VEC *sp_mv_mltadd(const VEC *v1, const VEC *v2, const SPMAT *A, + Real alpha, VEC *out) +{ + int i, j_idx, m, n, max_idx; + Real sum, *v2_ve; + SPROW *r; + row_elt *elts; + + if ( !A || !v1 || !v2 ) + error(E_NULL,"sp_mv_mltadd"); + if ( (int)v1->dim != A->m || (int)v2->dim != A->n ) + error(E_SIZES,"sp_mv_mltadd"); + if ( !out || (int)out->dim != A->m ) + out = v_resize(out, A->m); + + if (out != v1) + out = v_copy(v1, out); + + m = A->m; + n = A->n; + v2_ve = v2->ve; + + for ( i = 0; i < m; i++ ) + { + sum = 0.0; + r = &(A->row[i]); + max_idx = r->len; + elts = r->elt; + for ( j_idx = 0; j_idx < max_idx; j_idx++, elts++ ) + sum += elts->val*v2_ve[elts->col]; + out->ve[i] += alpha * sum; + } + + return out; +} + +/* sp_mv_symmlt -- symmetric sparse matrix/dense vector multiply + * -- only upper part of A is used (uA is unit upper diagonal) + * -- returns out == (uA' + diag(A) + uA) * v + * -- if out==NULL on entry then the result vector is created + */ +VEC *sp_mv_symmlt(SPMAT *A, const VEC *v, VEC *out) +{ + int i, j_idx, m, n, max_idx; + Real sum, tmp, *v_ve, *out_ve; + SPROW *r; + row_elt *elts; + + if ( !A || !v ) + error(E_NULL, "sp_mv_symmlt"); + if ( (int)v->dim != A->m ) + error(E_SIZES, "sp_mv_symmlt"); + if ( !out || (int)out->dim != A->m ) + out = v_resize(out, A->m); + if (out == v) + error(E_INSITU, "sp_mv_symmlt"); + + if (!A->flag_diag) + sp_diag_access(A); + + m = A->m; + n = A->n; + v_ve = v->ve; + out_ve = out->ve; + + v_zero(out); + for ( i = 0; i < m; i++ ) + { + tmp = v_ve[i]; + r = &(A->row[i]); + max_idx = r->len; + j_idx = r->diag; + if (j_idx < 0) { + sum = 0.0; + j_idx = -(j_idx + 2); + } + else { + sum = r->elt[j_idx].val * v_ve[i]; + j_idx ++; + } + elts = &(r->elt[j_idx]); + for (; j_idx < max_idx; j_idx++, elts++ ) { + sum += elts->val * v_ve[elts->col]; + out_ve[elts->col] += elts->val * tmp; + } + out_ve[i] += sum; + } + + return out; +} + +/* sp_vm_mltadd -- vector-matrix multiply and add + * -- may not be in situ (out != v2) + * -- returns out' == v1' + alpha*v2'*A + */ +VEC *sp_vm_mltadd(const VEC *v1, const VEC *v2, const SPMAT *A, + Real alpha, VEC *out) +{ + int i_idx, j, m, len; + Real tmp, *out_ve; + SPROW *row; + row_elt *elt; + + if ( ! v1 || ! v2 || ! A ) + error(E_NULL,"sp_vm_mltadd"); + if ( v2 == out ) + error(E_INSITU,"sp_vm_mltadd"); + if ( (int)v1->dim != A->n || A->m != (int)v2->dim ) + error(E_SIZES,"sp_vm_mltadd"); + if ( !out || (int)out->dim != A->n ) + out = v_resize(out, A->n); + + if (out != v1) + out = v_copy(v1, out); + + out_ve = out->ve; + m = A->m; + for (j=0; jve[j]*alpha; + if ( tmp != 0.0 ) { + row = &(A->row[j]); + len = row->len; + elt = row->elt; + for (i_idx=0; i_idxcol] += elt->val * tmp; + } + } + return out; +} + +/* + * routines for copying sparse matrices into band matrices + */ + +//------------------------------------------------------------------------- +void sp_into_bd(const SPMAT *sp, Real s, BAND *bd, const PERM *px, + int i_offs, int j_offs) +{ + int i, i_bd, i_end; + int j_bd, j_idx, j_end; + const row_elt *elt; + int lb = bd->lb; + Real **bde = bd->mat->me; + + i_end = sp->m; + for (i=0; ipe[i + i_offs]; + elt = sp->row[i].elt; + j_end = sp->row[i].len; + for (j_idx=0; j_idxpe[elt->col + j_offs]; + bde[lb + j_bd - i_bd][j_bd] = s * elt->val; + } + } +} + +//------------------------------------------------------------------------- +void spT_into_bd(const SPMAT *sp, Real s, BAND *bd, const PERM *px, + int i_offs, int j_offs) +{ + int j, j_bd, j_end; + int i_bd, i_idx, i_end; + const row_elt *elt; + int lb = bd->lb; + Real **bde = bd->mat->me; + + j_end = sp->m; + for (j=0; jpe[j + j_offs]; + elt = sp->row[j].elt; + i_end = sp->row[j].len; + for (i_idx=0; i_idxpe[elt->col + i_offs]; + bde[lb + j_bd - i_bd][j_bd] = s * elt->val; + } + } +} + +//------------------------------------------------------------------------- +void sp_into_sp(const SPMAT *src, Real s, SPMAT *dst, const PERM *px, + int i_offs, int j_offs) +{ + int i, i_dst, i_end; + int j_dst, j_idx, j_end; + const row_elt *elt; + + i_end = src->m; + for (i=0; ipe[i + i_offs]; + elt = src->row[i].elt; + j_end = src->row[i].len; + for (j_idx=0; j_idxpe[elt->col + j_offs]; + sp_set_val(dst, i_dst, j_dst, s * elt->val); + } + } +} + +//------------------------------------------------------------------------- +void spT_into_sp(const SPMAT *src, Real s, SPMAT *dst, const PERM *px, + int i_offs, int j_offs) +{ + int j, j_dst, j_end; + int i_dst, i_idx, i_end; + const row_elt *elt; + + j_end = src->m; + for (j=0; jpe[j + j_offs]; + elt = src->row[j].elt; + i_end = src->row[j].len; + for (i_idx=0; i_idxpe[elt->col + i_offs]; + sp_set_val(dst, i_dst, j_dst, s * elt->val); + } + } +} + +//------------------------------------------------------------------------- +void sp_into_symsp(const SPMAT *src, Real s, SPMAT *dst, const PERM *px, + int i_offs, int j_offs) +{ + int i, i_dst, i_end; + int j_dst, j_idx, j_end; + const row_elt *elt; + + i_end = src->m; + for (i=0; ipe[i + i_offs]; + elt = src->row[i].elt; + j_end = src->row[i].len; + for (j_idx=0; j_idxpe[elt->col + j_offs]; + if (i_dst <= j_dst) + sp_set_val(dst, i_dst, j_dst, s * elt->val); + } + } +} + +//------------------------------------------------------------------------- +void symsp_into_symsp(const SPMAT *src, Real s, SPMAT *dst, const PERM *px, + int offs) +{ + int i, j, i_dst, i_end; + int j_dst, j_idx, j_end; + const row_elt *elt; + + i_end = src->m; + for (i = 0; i < i_end; i++) { + i_dst = px->pe[i + offs]; + elt = src->row[i].elt; + j_end = src->row[i].len; + for (j_idx=0; j_idxcol; + /* take only diagonal and upper diagonal entries */ + if (j >= i) { + j_dst = px->pe[j + offs]; + if (j_dst >= i_dst) + sp_set_val(dst, i_dst, j_dst, s * elt->val); + else + sp_set_val(dst, j_dst, i_dst, s * elt->val); + } + } + } +} + +//------------------------------------------------------------------------- +void spT_into_symsp(const SPMAT *src, Real s, SPMAT *dst, const PERM *px, + int i_offs, int j_offs) +{ + int j, j_dst, j_end; + int i_dst, i_idx, i_end; + const row_elt *elt; + + j_end = src->m; + for (j=0; jpe[j + j_offs]; + elt = src->row[j].elt; + i_end = src->row[j].len; + for (i_idx=0; i_idxpe[elt->col + i_offs]; + if (i_dst <= j_dst) + sp_set_val(dst, i_dst, j_dst, s * elt->val); + } + } +} + + +//========================================================================= diff --git a/hqp/Meschach.h b/hqp/Meschach.h new file mode 100644 index 0000000..8afdefa --- /dev/null +++ b/hqp/Meschach.h @@ -0,0 +1,331 @@ +/* + * Meschach.h -- Meschach declarations and some extensions + * + * rf, 8/18/94 + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke and Eckhard Arnold + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Meschach_H +#define Meschach_H + +#include + +#if defined(_MSC_VER) +// Include math.h prior to matrix.h +// as matrix.h would include it otherwise +// and as extern "C" specification does not work for MSC's math.h. +#include +#endif + +extern "C" { +#include +#include +} + +extern IVEC *iv_set(IVEC *, int); +extern IVEC *iv_part(IVEC *iv, int offs, int dim, IVEC *header); +extern IVEC *iv_expand(IVEC *iv, int nel, int granul); + +extern VEC *v_set(VEC *, Real); +extern VEC *v_part(VEC *v, int offs, int dim, VEC *header); +extern VEC *v_expand(VEC *v, int nel, int granul); +extern VEC *bd_mv_mlt(const BAND *, const VEC *, VEC *); + +extern MAT *m_mltadd(const MAT *, const MAT *, Real, MAT *); + +extern Real sp_norm_inf(SPMAT *); +extern SPMAT *sp_copy3(const SPMAT *, SPMAT *); +extern int sp_update_val(SPMAT *, int, int, Real); +extern void sp_insert_mat(SPMAT *dst, int i_offs, int j_offs, const MAT *src); +extern void symsp_insert_symmat(SPMAT *dst, int offs, const MAT *src); +extern void sp_update_mat(SPMAT *dst, int i_offs, int j_offs, const MAT *src); +extern void sp_extract_mat(const SPMAT *src, int i_offs, int j_offs, MAT *dst); +extern void symsp_extract_mat(const SPMAT *src, int offs, MAT *dst); +extern void sp_insert_mrow(SPMAT *dst, int i_offs, int j_offs, + const MAT *src, int i); +extern void sp_update_mrow(SPMAT *dst, int i_offs, int j_offs, + const MAT *src, int i); +extern void sp_extract_mrow(const SPMAT *src, int i_offs, int j_offs, + MAT *dst, int i); +extern SPMAT *sp_ident(SPMAT *); +extern SPMAT *sp_ones(SPMAT *); +extern VEC *sp_mv_mltadd(const VEC *v1, const VEC *v2, const SPMAT *A, + Real alpha, VEC *out); +extern VEC *sp_vm_mltadd(const VEC *v1, const VEC *v2, const SPMAT *A, + Real alpha, VEC *out); +extern VEC *sp_mv_symmlt(SPMAT *A, const VEC *v, VEC *out); + +extern Real sprow_inprod(const SPROW *r1, const VEC *inner, const SPROW *r2); +extern void sprow_zero(SPROW *row); + +extern SPMAT *spLUfactor2(SPMAT *A, PERM *px); +extern SPMAT *sp_transp(const SPMAT *, SPMAT *); + +/* + * BKP factor and solve routines + */ + +extern MAT *matBKPfactor(MAT *A, PERM *pivot); +extern VEC *matBKPsolve(const MAT *A, const PERM *pivot, + const VEC *b, VEC *x); + +extern BAND *bdBKPfactor(BAND *A, PERM *pivot, PERM *relief); +extern VEC *bdBKPsolve(const BAND *A, const PERM *pivot, const PERM *relief, + const VEC *b, VEC *x); + +extern SPMAT *spBKPfactor(SPMAT *, PERM *pivot, Real tol); +extern VEC *spBKPsolve(const SPMAT *, const PERM *pivot, + const VEC *b, VEC *x); + +/* + * routines for copying sparse matrices into sparse/band matrices + * -- "sym" means, that only the upper part of a symmetric matrix is filled + */ + +extern void sp_into_sp(const SPMAT *src, Real s, SPMAT *dst, + const PERM *px, int i_offs, int j_offs); +extern void spT_into_sp(const SPMAT *src, Real s, SPMAT *dst, + const PERM *px, int i_offs, int j_offs); +extern void sp_into_symsp(const SPMAT *src, Real s, SPMAT *dst, + const PERM *px, int i_offs, int j_offs); +extern void symsp_into_symsp(const SPMAT *src, Real s, SPMAT *dst, + const PERM *px, int offs); +extern void spT_into_symsp(const SPMAT *src, Real s, SPMAT *dst, + const PERM *px, int i_offs, int j_offs); + +extern void sp_into_bd(const SPMAT *sp, Real s, BAND *bd, + const PERM *px, int i_offs, int j_offs); +extern void spT_into_bd(const SPMAT *sp, Real s, BAND *bd, + const PERM *px, int i_offs, int j_offs); + +// overload operators for Meschach data structures (esp. operator []) +// idea: +// - define for any STRUCT a class STRUCTP +// - data representation of STRUCTP is compatible to STRUCT* +// - overload operators as needed +// a C synonym can be thought as: +// typedef STRUCT* STRUCTP +// bugs: +// - Meschach prototypes have no const's --> bad const handling +// (VEC *v_add(VEC *a, VEC *b, VEC *out) instead of +// VEC *v_add(const VEC *a, const VEC *b, VEC *out) + +#ifdef DEBUG +#define MESCH_BOUNDS_CHECK(i, first_index, next_index) \ + assert((int)(first_index) <= (int)(i) && (int)(i) < (int)(next_index)) +#else +#define MESCH_BOUNDS_CHECK(i, first_index, next_index) +#endif + +#ifdef DEBUG +#define MESCH_NULL_CHECK(ptr) \ + assert (ptr != NULL) +#else +#define MESCH_NULL_CHECK(ptr) +#endif + +/** Wrapper for VEC*. */ +class VECP { + + protected: + VEC *_v; + + public: + // constructors and assignments + VECP() {_v = VNULL;} + VECP(VEC *cv) {_v = cv;} + + VEC *operator = (VEC *nv) {_v = nv; return _v;} + + // overloaded operators + Real &operator [] (int j) + { + MESCH_NULL_CHECK(_v); + MESCH_BOUNDS_CHECK(j, 0, _v->dim); + return _v->ve[j]; + } + VEC *operator -> () {return _v;} + operator VEC*() {return _v;} + // additional conversion to avoid warning of gcc2.95 + operator const VEC*() {return _v;} + + // operators for const VECP + const Real &operator [] (int j) const + { + MESCH_NULL_CHECK(_v); + MESCH_BOUNDS_CHECK(j, 0, _v->dim); + return _v->ve[j]; + } + const VEC *operator -> () const {return _v;} + operator const VEC*() const {return _v;} +}; + +/** Wrapper for IVEC*. */ +class IVECP { + + protected: + IVEC *_v; + + public: + // constructors and assignment + IVECP() {_v = IVNULL;} + IVECP(IVEC *cv) {_v = cv;} + + IVEC *operator = (IVEC *nv) {_v = nv; return _v;} + + // operators + int &operator [] (int j) + { + MESCH_NULL_CHECK(_v); + MESCH_BOUNDS_CHECK(j, 0, _v->dim); + return _v->ive[j]; + } + IVEC *operator -> () {return _v;} + operator IVEC*() {return _v;} + // additional conversion to avoid warning of gcc2.95 + operator const IVEC*() {return _v;} + + // operators for const IVECP + const int &operator [] (int j) const + { + MESCH_NULL_CHECK(_v); + MESCH_BOUNDS_CHECK(j, 0, _v->dim); + return _v->ive[j]; + } + const IVEC *operator -> () const {return _v;} + operator const IVEC*() const {return _v;} +}; + +/** Wrapper for PERM*. */ +class PERMP { + + protected: + PERM *_v; + + public: + // constructors and assignment + PERMP() {_v = PNULL;} + PERMP(PERM *cv) {_v = cv;} + + PERM *operator = (PERM *nv) {_v = nv; return _v;} + + // operators + u_int &operator [] (int j) + { + MESCH_NULL_CHECK(_v); + MESCH_BOUNDS_CHECK(j, 0, _v->size); + return _v->pe[j]; + } + PERM *operator -> () {return _v;} + operator PERM*() {return _v;} + // additional conversion to avoid warning of gcc2.95 + operator const PERM*() {return _v;} + + // operators for const PERMP + const u_int &operator [] (int j) const + { + MESCH_NULL_CHECK(_v); + MESCH_BOUNDS_CHECK(j, 0, _v->size); + return _v->pe[j]; + } + const PERM *operator -> () const {return _v;} + operator const PERM*() const {return _v;} +}; + +/** Wrapper for row in MAT*. */ +class MATROWP { + + protected: + Real *_row; + int _dim; + + public: + MATROWP(Real *row, int dim) {_row = row; _dim = dim;} + + Real &operator [] (int j) + { + MESCH_BOUNDS_CHECK(j, 0, _dim); + return _row[j]; + } + operator Real*() {return _row;} + + const Real &operator [] (int j) const + { + MESCH_BOUNDS_CHECK(j, 0, _dim); + return _row[j]; + } + operator const Real*() const {return _row;} +}; + +/** Wrapper for MAT*. */ +class MATP { + + protected: + MAT *_m; + + public: + // constructors and assignment + MATP() {_m = MNULL;} + MATP(MAT *cm) {_m = cm;} + + MAT *operator = (MAT *nm) {_m = nm; return _m;} + + // operators +# ifdef DEBUG + MATROWP operator [] (int i) + { + MESCH_NULL_CHECK(_m); + MESCH_BOUNDS_CHECK(i, 0, _m->m); + return MATROWP(_m->me[i], _m->n); + } +# else + Real *operator [] (int i) + { + return _m->me[i]; + } +# endif + MAT *operator -> () {return _m;} + operator MAT*() {return _m;} + // additional conversion to avoid warning of gcc2.95 + operator const MAT*() {return _m;} + + // operators for const MATP +# ifdef DEBUG + const MATROWP operator [] (int i) const + { + MESCH_NULL_CHECK(_m); + MESCH_BOUNDS_CHECK(i, 0, _m->m); + return MATROWP(_m->me[i], _m->n); + } +# else + const Real *operator [] (int i) const + { + return _m->me[i]; + } +# endif + const MAT *operator -> () const {return _m;} + operator const MAT*() const {return _m;} +}; + +typedef SPMAT* SPMATP; +typedef BAND* BANDP; + +#endif diff --git a/hqp/Prg_ASCEND.C b/hqp/Prg_ASCEND.C new file mode 100644 index 0000000..98b40f1 --- /dev/null +++ b/hqp/Prg_ASCEND.C @@ -0,0 +1,463 @@ +/* + * Prg_ASCEND.C -- class definition + * + * rf, 12/17/99 + */ + +/* + Copyright (C) 1999 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include "Prg_ASCEND.h" +#include "Hqp_Program.h" +#include "Hqp_SqpSolver.h" + +#include + +#include +#include + +IF_CLASS_DEFINE("ASCEND", Prg_ASCEND, Hqp_SqpProgram); + +//------------------------------------------------------------------------- +Prg_ASCEND::Prg_ASCEND() +{ + _nvars = 0; + _nrels = 0; + _vars = NULL; + _rels = NULL; + _obj = NULL; + _safe_calc = TRUE; + _var_lb = v_resize(v_get(1), 0); + _var_ub = v_resize(v_get(1), 0); + _var_asc2hqp = iv_resize(iv_get(1), 0); + _derivatives = v_resize(v_get(1), 0); + _var_master_idxs = iv_resize(iv_get(1), 0); + _var_solver_idxs = iv_resize(iv_get(1), 0); + _Inf = 1e38; // todo: should be initialized from ASCEND data + _me_bounds = 0; + _m_bounds = 0; + memset(&_slv_status, 0, sizeof(slv_status_t)); + + // create interface elements + _ifList.append(new If_Int("prg_safe_calc", &_safe_calc)); + + slv_register_client(Prg_ASCEND::slv_register, NULL, NULL); +} + +//------------------------------------------------------------------------- +Prg_ASCEND::~Prg_ASCEND() +{ + iv_free(_var_solver_idxs); + iv_free(_var_master_idxs); + v_free(_derivatives); + iv_free(_var_asc2hqp); + v_free(_var_ub); + v_free(_var_lb); +} + +//------------------------------------------------------------------------- +int Prg_ASCEND::slv_register(SlvFunctionsT *sft) +{ + if (sft == NULL) { + FPRINTF(stderr,"Prg_ASCEND::slv_register called with NULL pointer\n"); + return 1; + } + fprintf(stderr, "Prg_ASCEND::slv_register called\n"); + + sft->name = "HQP"; + sft->ccreate = Prg_ASCEND::slv_create; + sft->cdestroy = Prg_ASCEND::slv_destroy; + sft->getstatus = Prg_ASCEND::slv_get_status; + sft->presolve = Prg_ASCEND::slv_presolve; + //sft->solve = Prg_ASCEND::slv_solve; + sft->iterate = Prg_ASCEND::slv_iterate; + return 0; +} + +//------------------------------------------------------------------------- +SlvClientToken Prg_ASCEND::slv_create(slv_system_t, int *status_index) +{ + extern Hqp_SqpSolver *theSqpSolver; + fprintf(stderr, "Prg_ASCEND::slv_create called\n"); + *status_index = 0; + return (SlvClientToken)theSqpSolver; +} + +//------------------------------------------------------------------------- +int Prg_ASCEND::slv_destroy(slv_system_t, SlvClientToken) +{ + fprintf(stderr, "Prg_ASCEND::slv_destroy called\n"); + return 0; +} + +//------------------------------------------------------------------------- +void Prg_ASCEND::slv_get_status(slv_system_t, SlvClientToken clt, + slv_status_t *status) +{ + //fprintf(stderr, "Prg_ASCEND::slv_get_status called\n"); + + Hqp_SqpSolver *sqp = (Hqp_SqpSolver *)clt; + Prg_ASCEND *prg = (Prg_ASCEND *)sqp->prg(); + // todo: assert prg != NULL && prg->name() == "ASCEND" + + *status = prg->_slv_status; +} + +//------------------------------------------------------------------------- +void Prg_ASCEND::slv_presolve(slv_system_t system, SlvClientToken clt) +{ + fprintf(stderr, "Prg_ASCEND::slv_presolve called\n"); + + Hqp_SqpSolver *sqp = (Hqp_SqpSolver *)clt; + Prg_ASCEND *prg = (Prg_ASCEND *)sqp->prg(); + // todo: assert prg != NULL && prg->name() == "ASCEND" + + prg->_slv_system = system; + prg->setup(); + prg->init_x(); + + sqp->init(); + + prg->_slv_status.calc_ok = TRUE; + prg->_slv_status.ok = TRUE; + prg->_slv_status.ready_to_solve = TRUE; + prg->_slv_status.iteration = 0; +} + +//------------------------------------------------------------------------- +void Prg_ASCEND::slv_iterate(slv_system_t, SlvClientToken clt) +{ + //fprintf(stderr, "Prg_ASCEND::slv_iterate called\n"); + + Hqp_SqpSolver *sqp = (Hqp_SqpSolver *)clt; + Prg_ASCEND *prg = (Prg_ASCEND *)sqp->prg(); + // todo: assert prg != NULL && prg->name() == "ASCEND" + + // currently call Tcl command hqp_solve + // todo: replace with calls to sqp->{qp_update, qp_solve, step}() + extern Tcl_Interp *theInterp; + char *tcl_channel = "stdout"; + sqp->set_max_iters(sqp->iter() + 1); // allow one iteration + if (Tcl_VarEval(theInterp, "hqp_solve ", tcl_channel, NULL) == TCL_OK) { + prg->_slv_status.converged = TRUE; + prg->_slv_status.ready_to_solve = FALSE; + } + else if (strcmp(theInterp->result, "iters") != 0) { + prg->_slv_status.ok = FALSE; + prg->_slv_status.ready_to_solve = FALSE; + Tcl_VarEval(theInterp, "puts ", tcl_channel, + " \"HQP Error: ", theInterp->result, "\"", NULL); + } + + prg->_slv_status.iteration = sqp->iter(); +} + +//------------------------------------------------------------------------- +void Prg_ASCEND::slv_solve(slv_system_t, SlvClientToken clt) +{ + fprintf(stderr, "Prg_ASCEND::slv_solve called\n"); + + Hqp_SqpSolver *sqp = (Hqp_SqpSolver *)clt; + Prg_ASCEND *prg = (Prg_ASCEND *)sqp->prg(); + // todo: assert prg != NULL && prg->name() == "ASCEND" + + // currently call Tcl command hqp_solve + // todo: replace with call to sqp->solve() + extern Tcl_Interp *theInterp; + Tcl_Eval(theInterp, "hqp_solve"); + + prg->_slv_status.ready_to_solve = FALSE; + prg->_slv_status.iteration = sqp->iter(); +} + +//------------------------------------------------------------------------- +void Prg_ASCEND::setup() +{ + int n, me, m; + int i, j, row_idx, idx; + SPMAT *J; + int nincidences; + const struct var_variable **incidences; + + // obtain ASCEND system + // todo: should check that system can be solved with HQP (e.g. no integers) + _nvars = slv_get_num_solvers_vars(_slv_system); + _vars = slv_get_solvers_var_list(_slv_system); + _nrels = slv_get_num_solvers_rels(_slv_system); + _rels = slv_get_solvers_rel_list(_slv_system); + _obj = slv_get_obj_relation(_slv_system); + + // count number of optimization variables and bounds + _var_lb = v_resize(_var_lb, _nvars); + _var_ub = v_resize(_var_ub, _nvars); + _var_asc2hqp = iv_resize(_var_asc2hqp, _nvars); + _derivatives = v_resize(_derivatives, _nvars); + _var_master_idxs = iv_resize(_var_master_idxs, _nvars); + _var_solver_idxs = iv_resize(_var_solver_idxs, _nvars); + n = 0; + me = 0; + m = 0; + for (i = 0; i < _nvars; i++) { + _var_lb[i] = var_lower_bound(_vars[i]); + _var_ub[i] = var_upper_bound(_vars[i]); + /* + var_write_name(_slv_system, _vars[i], stderr); + fprintf(stderr, ":\t%i,\t%g,\t%g\n", var_fixed(_vars[i]), + _var_lb[i], _var_ub[i]); + */ + if (var_fixed(_vars[i])) { + _var_asc2hqp[i] = -1; + } + else { + _var_asc2hqp[i] = n++; + if (_var_lb[i] == _var_ub[i]) + ++me; + else { + if (_var_lb[i] > -_Inf) + ++m; + if (_var_ub[i] < _Inf) + ++m; + } + } + } + + // consider bounds as linear constraints (i.e. no Jacobian update) + _me_bounds = me; + _m_bounds = m; + + // count number of HQP constraints + for (i = 0; i < _nrels; i++) { + if (rel_equal(_rels[i])) + ++me; // equality constraint + else + ++m; // inequality constraint + } + + // allocate QP approximation and optimization variables vector + _qp->resize(n, me, m); + _x = v_resize(_x, n); + + // allocate sparse structure for bounds + // (write constant elements in Jacobians) + me = m = 0; + for (i = 0; i < _nvars; i++) { + idx = _var_asc2hqp[i]; + if (idx < 0) + continue; + if (_var_lb[i] == _var_ub[i]) { + row_idx = me++; + sp_set_val(_qp->A, row_idx, idx, 1.0); + } + else { + if (_var_lb[i] > -_Inf) { + row_idx = m++; + sp_set_val(_qp->C, row_idx, idx, 1.0); + } + if (_var_ub[i] < _Inf) { + row_idx = m++; + sp_set_val(_qp->C, row_idx, idx, -1.0); + } + } + } + + // allocate sparse structure for general constraints + // (just insert dummy values; actual values are set in update method) + for (i = 0; i < _nrels; i++) { + if (rel_equal(_rels[i])) { + row_idx = me++; + J = _qp->A; + } + else { + row_idx = m++; + J = _qp->C; + } + nincidences = rel_n_incidences(_rels[i]); + incidences = rel_incidence_list(_rels[i]); + for (j = 0; j < nincidences; j++) { + idx = _var_asc2hqp[var_sindex(incidences[j])]; + if (idx >= 0) + sp_set_val(J, row_idx, idx, 1.0); + } + } + + // todo: setup sparse structure of Hessian + // for now initialize something resulting in dense BFGS update + for (j = 0; j < n-1; j++) { + sp_set_val(_qp->Q, j, j, 0.0); + sp_set_val(_qp->Q, j, j+1, 0.0); + } + sp_set_val(_qp->Q, j, j, 0.0); +} + +//------------------------------------------------------------------------- +void Prg_ASCEND::init_x() +{ + int i, idx; + for (i = 0; i < _nvars; i++) { + idx = _var_asc2hqp[i]; + if (idx >= 0) + _x[idx] = var_value(_vars[i]); + } +} + +//------------------------------------------------------------------------- +void Prg_ASCEND::update_bounds() +{ + int j; + int m, me, idx, row_idx; + + m = me = 0; + for (j = 0; j < _nvars; j++) { + idx = _var_asc2hqp[j]; + if (idx < 0) + continue; + if (_var_lb[j] == _var_ub[j]) { + row_idx = me++; + _qp->b[row_idx] = _x[idx] - _var_lb[j]; + } + else { + if (_var_lb[j] > -_Inf) { + row_idx = m++; + _qp->d[row_idx] = _x[idx] - _var_lb[j]; + } + if (_var_ub[j] < _Inf) { + row_idx = m++; + _qp->d[row_idx] = _var_ub[j] - _x[idx]; + } + } + } +} + +//------------------------------------------------------------------------- +void Prg_ASCEND::update_fbd() +{ + int i, idx, row_idx; + int m, me; + int32 calc_ok; + double residual, mult; + + // write current optimization variables to ASCEND + for (i = 0; i < _nvars; i++) { + idx = _var_asc2hqp[i]; + if (idx >= 0) + var_set_value(_vars[i], _x[idx]); + } + + // update variable bounds + update_bounds(); + + // update objective + _f = relman_eval(_obj, &calc_ok, _safe_calc); + _slv_status.calc_ok &= calc_ok; + + // update general constraints + me = _me_bounds; + m = _m_bounds; + for (i = 0; i < _nrels; i++) { + residual = relman_eval(_rels[i], &calc_ok, _safe_calc); + _slv_status.calc_ok &= calc_ok; + if (rel_equal(_rels[i])) { + row_idx = me++; + _qp->b[row_idx] = residual; + } + else { + row_idx = m++; + mult = rel_less(_rels[i])? -1.0: 1.0; + _qp->d[row_idx] = mult * residual; + } + } +} + +//------------------------------------------------------------------------- +void Prg_ASCEND::update(const VECP y, const VECP z) +{ + var_filter_t vfilter; + int i, j, row_idx, idx; + int m, me; + int32 count; + int status, newel; + real64 residual; + double mult; + SPMAT *J; + + // write current optimization variables to ASCEND + for (j = 0; j < _nvars; j++) { + idx = _var_asc2hqp[j]; + if (idx >= 0) + var_set_value(_vars[j], _x[idx]); + } + + // update variable bounds + update_bounds(); + + // initialize vfilter so that all optimization variables are considered + vfilter.matchbits = (VAR_ACTIVE | VAR_INCIDENT | VAR_SVAR | VAR_FIXED); + vfilter.matchvalue = (VAR_ACTIVE | VAR_INCIDENT | VAR_SVAR); + + // update objective and derivatives + status = relman_diff_grad(_obj, &vfilter, _derivatives->ve, + _var_master_idxs->ive, _var_solver_idxs->ive, + &count, &residual, _safe_calc); + if (status == 0) // todo: this contradicts docu in solver/relman.h!? + _slv_status.calc_ok &= FALSE; + _f = residual; + for (j = 0; j < count; j++) { + idx = _var_asc2hqp[_var_solver_idxs[j]]; + if (idx >= 0) + _qp->c[idx] = _derivatives[j]; + } + + // update general constraints + me = _me_bounds; + m = _m_bounds; + newel = 0; + for (i = 0; i < _nrels; i++) { + status = relman_diff_grad(_rels[i], &vfilter, _derivatives->ve, + _var_master_idxs->ive, _var_solver_idxs->ive, + &count, &residual, _safe_calc); + if (status == 0) // todo: this contradicts docu in solver/relman.h!? + _slv_status.calc_ok &= FALSE; + if (rel_equal(_rels[i])) { + row_idx = me++; + mult = 1.0; + _qp->b[row_idx] = residual; + J = _qp->A; + } + else { + row_idx = m++; + mult = rel_less(_rels[i])? -1.0: 1.0; + _qp->d[row_idx] = mult * residual; + J = _qp->C; + } + sprow_zero(J->row + row_idx); + for (j = 0; j < count; j++) { + idx = _var_asc2hqp[_var_solver_idxs[j]]; + if (idx >= 0) + newel |= sp_update_val(J, row_idx, idx, mult * _derivatives[j]); + } + } + if (newel) { + // the sparsity structure has changed + _slv_status.ok = FALSE; + _slv_status.inconsistent = TRUE; + _slv_status.ready_to_solve = FALSE; + } +} + +//========================================================================= diff --git a/hqp/Prg_ASCEND.h b/hqp/Prg_ASCEND.h new file mode 100644 index 0000000..2f4a108 --- /dev/null +++ b/hqp/Prg_ASCEND.h @@ -0,0 +1,129 @@ +/* + * Prg_ASCEND.h -- + * - convert an ASCEND system into a Hqp_SqpProgram + * + * rf, 12/17/99 + */ + +/* + Copyright (C) 1999 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Prg_ASCEND_H +#define Prg_ASCEND_H + +#include "Hqp_SqpProgram.h" + +/* + * Includes required for ASCEND + */ + +extern "C" { +#include "utilities/ascConfig.h" +#include "utilities/ascMalloc.h" +#include "utilities/set.h" +#include "general/time.h" +#include "utilities/mem.h" +#include "general/list.h" +#include "compiler/fractions.h" +#include "compiler/dimen.h" +#include "compiler/functype.h" +#include "compiler/func.h" +#include "solver/mtx.h" +#include "solver/linsol.h" +#include "solver/linsolqr.h" +#include "solver/slv_types.h" +#include "solver/var.h" +#include "solver/rel.h" +#include "solver/discrete.h" +#include "solver/conditional.h" +#include "solver/logrel.h" +#include "solver/bnd.h" +#include "solver/calc.h" +#include "solver/relman.h" +#include "solver/slv_common.h" +#include "solver/slv_client.h" +}; + +/* + * class declaration + */ + +class Prg_ASCEND: public Hqp_SqpProgram { + + protected: + slv_system_t _slv_system; + + int _nvars; // number of ASCEND variables + int _nrels; // number of ASCEND relations + struct var_variable **_vars; // ASCEND variables + struct rel_relation **_rels; // ASCEND relations + struct rel_relation *_obj; // ASCEND objective relation + int _safe_calc; // apply ASCEND's safe calculation + + VECP _var_lb; // lower bounds for ASCEND variables + VECP _var_ub; // upper bounds for ASCEND variables + IVECP _var_asc2hqp; // map ASCEND var index to HQP + + VECP _derivatives; // derivatives of ASCEND relation + IVECP _var_master_idxs; // variable indices for derivatives + IVECP _var_solver_idxs; // variable indices for derivatives + + double _Inf; // infinite value to check for existence of bounds + int _me_bounds; // number of linear equality constraints for HQP + int _m_bounds; // number of linear inequality constraints for HQP + + slv_status_t _slv_status; + + void update_bounds(); + + public: + + Prg_ASCEND(); + ~Prg_ASCEND(); + + /* + * Client functions called by ASCEND + */ + + static int slv_register(SlvFunctionsT *); + static SlvClientToken slv_create(slv_system_t, int *); + static int slv_destroy(slv_system_t, SlvClientToken); + static void slv_get_status(slv_system_t, SlvClientToken, + slv_status_t *); + static void slv_presolve(slv_system_t, SlvClientToken); + static void slv_iterate(slv_system_t, SlvClientToken); + static void slv_solve(slv_system_t, SlvClientToken); + + /* + * implementation of interface defined by Hqp_SqpProgram + */ + + void setup(); + void init_x(); + + void update_fbd(); + void update(const VECP y, const VECP z); + + char *name() {return "ASCEND";} +}; + + +#endif + + diff --git a/hqp/Prg_CUTE.C b/hqp/Prg_CUTE.C new file mode 100644 index 0000000..ad85659 --- /dev/null +++ b/hqp/Prg_CUTE.C @@ -0,0 +1,573 @@ +/* + * Prg_CUTE.C -- class definition + * + * rf, 10/27/95 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include +#include + +#include "Prg_CUTE.h" +#include "Hqp_Program.h" + +#include +#include +#include +#include +#include + +extern "C" { + csize_t csize_; + cinit_t cinit_; + cfn_t cfn_; + csgr_t csgr_; + csgrsh_t csgrsh_; + csgreh_t csgreh_; + cwrtsn_t cwrtsn_; +} + +typedef If_Method If_Cmd; + +IF_CLASS_DEFINE("CUTE", Prg_CUTE, Hqp_SqpProgram); + +//------------------------------------------------------------------------- +Prg_CUTE::Prg_CUTE() +{ + _csize_p = NULL; + _cinit_p = NULL; + _cfn_p = NULL; + _csgr_p = NULL; + _csgrsh_p = NULL; + _csgreh_p = NULL; + _cwrtsn_p = NULL; + + _fscale = 1.0; + _x0 = VNULL; + _var_lb = VNULL; + _var_ub = VNULL; + _cns_lb = VNULL; + _cns_ub = VNULL; + _cns = VNULL; + _J = VNULL; + _H = VNULL; + _v = VNULL; + _var_ridx = IVNULL; + _cns_ridx = IVNULL; + + _fbd_evals = 0; + + _INDVAR = NULL; + _INDFUN = NULL; + _IRNSH = NULL; + _ICNSH = NULL; + + _hela = false; + _hela_init = true; + _ifList.append(new If_Float("prg_fscale", &_fscale)); + _ifList.append(new If_Bool("prg_hela", &_hela)); + _ifList.append(new If_Bool("prg_hela_init", &_hela_init)); + _ifList.append(new If_Int("prg_fbd_evals", &_fbd_evals)); + _ifList.append(new If_Cmd("prg_write_soln", &Prg_CUTE::write_soln, this)); +} + +//------------------------------------------------------------------------- +Prg_CUTE::~Prg_CUTE() +{ + v_free(_x0); + v_free(_var_lb); + v_free(_var_ub); + v_free(_cns_lb); + v_free(_cns_ub); + v_free(_cns); + v_free(_J); + v_free(_H); + v_free(_v); + iv_free(_var_ridx); + iv_free(_cns_ridx); + + delete [] _INDVAR; + delete [] _INDFUN; + delete [] _IRNSH; + delete [] _ICNSH; +} + +//------------------------------------------------------------------------- +void Prg_CUTE::parse_bounds(const Real *l_ve, const Real *u_ve, int n, + int *ridx_ive, int *me, int *m) +{ + int i; + + for (i=0; i -_Inf) + ridx_ive[i] = (*m) ++; + if (u_ve[i] < _Inf) { + if (ridx_ive[i] == -1) + ridx_ive[i] = (*m) ++; + else + (*m) ++; + } + } + } +} + +//------------------------------------------------------------------------- +void Prg_CUTE::setup() +{ + int me, m; // number of equality and inequality constraints + int i, offs; + int *ridx_ive; + Real *l_ve, *u_ve; + fbool *EQUATN, *LINEAR; + fbool EFIRST = 0; + fbool LFIRST = 0; + fbool NVFRST = 0; + + /* + * bind the problem + */ + + _csize_p = (csize_t*)&csize_; + _cinit_p = (cinit_t*)&cinit_; + _cfn_p = (cfn_t*)&cfn_; + _csgr_p = (csgr_t*)&csgr_; + _csgrsh_p = (csgrsh_t*)&csgrsh_; + _csgreh_p = (csgreh_t*)&csgreh_; + _cwrtsn_p = (cwrtsn_t*)&cwrtsn_; + + /* + * get the problem size; allocate and initialize variables + */ + + (*_csize_p)(&_N, &_M, &_NNZJMAX, &_NNZHMAX); + + _x0 = v_resize(_x0, _N); + _var_lb = v_resize(_var_lb, _N); + _var_ub = v_resize(_var_ub, _N); + _v = v_resize(_v, _M); + _cns_lb = v_resize(_cns_lb, _M); + _cns_ub = v_resize(_cns_ub, _M); + EQUATN = new fbool [_M]; + LINEAR = new fbool [_M]; + + (*_cinit_p)(&_N, &_M, _x0->ve, _var_lb->ve, _var_ub->ve, &_Inf, + EQUATN, LINEAR, _v->ve, _cns_lb->ve, _cns_ub->ve, + &EFIRST, &LFIRST, &NVFRST); + + _x0->dim = _N; + _var_lb->dim = _N; + _var_ub->dim = _N; + _var_ridx = iv_resize(_var_ridx, _N); + _v->dim = _M; + _cns_lb->dim = _M; + _cns_ub->dim = _M; + _cns_ridx = iv_resize(_cns_ridx, _M); + _cns = v_resize(_cns, _M); + + me = 0; + m = 0; + parse_bounds(_var_lb->ve, _var_ub->ve, _N, _var_ridx->ive, &me, &m); + _me_lin = me; + _m_lin = m; + parse_bounds(_cns_lb->ve, _cns_ub->ve, _M, _cns_ridx->ive, &me, &m); + + delete [] EQUATN; + delete [] LINEAR; + + /* + * allocate and initialize _x and _qp, including sparsity pattern + */ + + delete [] _INDVAR; + delete [] _INDFUN; + delete [] _IRNSH; + delete [] _ICNSH; + + _J = v_resize(_J, _NNZJMAX); + _INDVAR = new fint [_NNZJMAX]; + _INDFUN = new fint [_NNZJMAX]; + _H = v_resize(_H, _NNZHMAX); + _IRNSH = new fint [_NNZHMAX]; + _ICNSH = new fint [_NNZHMAX]; + + _qp->resize(_N, me, m); + _x = v_resize(_x, _N); + + // variable bounds + + l_ve = _var_lb->ve; + u_ve = _var_ub->ve; + ridx_ive = _var_ridx->ive; + for (i=0; i<_N; i++) { + if (l_ve[i] == u_ve[i]) + sp_set_val(_qp->A, ridx_ive[i], i, 1.0); + else { + offs = 0; + if (l_ve[i] > -_Inf) { + sp_set_val(_qp->C, ridx_ive[i], i, 1.0); + offs = 1; + } + if (u_ve[i] < _Inf) + sp_set_val(_qp->C, ridx_ive[i] + offs, i, -1.0); + } + } + + /* + * The structure resulting from general constraints can't be + * initialized here, as there exists no appropriate procedure + * call in the CUTE package. + */ + + _NNZJ = _NNZH = 0; + +#if 0 + /* + * evaluate csgreh_ and setup struct for Jacobians and Lagrangian Hessian + */ + + fbool GRLAGF = 0; + fbool BYROWS = 1; + fint NHI; + fint *IRNHI = _IRNSH; + fint LIRNHI = _NNZHMAX; + fint LE = _NNZHMAX / 2; + fint *IPRNHI = _ICNSH; + fint *IPRHI = _ICNSH + LE; + int j, k, idx, idx_end; + int iidx, jidx, ijidx_end; + + sv_mlt(1.0/_fscale, _v, _v); + if (_hela_init || _hela) { + (*_csgreh_p)(&_N, &_M, _x0->ve, &GRLAGF, &_M, _v->ve, + &_NNZJ, &_NNZJMAX, _J->ve, _INDVAR, _INDFUN, + &NHI, IRNHI, &LIRNHI, + &LE, IPRNHI, _H->ve, &_NNZHMAX, IPRHI, &BYROWS); + } + else { + (*_csgr_p)(&_N, &_M, &GRLAGF, &_M, _v->ve, _x0->ve, + &_NNZJ, &_NNZJMAX, _J->ve, _INDVAR, _INDFUN); + } + sv_mlt(_fscale, _v, _v); + + // general constraints + + v_zero(_qp->c); + l_ve = _cns_lb->ve; + u_ve = _cns_ub->ve; + ridx_ive = _cns_ridx->ive; + for (idx = 0; idx < _NNZJ; idx++) { + i = _INDFUN[idx] - 1; + j = _INDVAR[idx] - 1; + if (i == -1) + _qp->c[j] = _fscale * J_ve[idx]; + if (i >= 0) { + if (l_ve[i] == u_ve[i]) + sp_set_val(_qp->A, ridx_ive[i], j, 0.0); + else { + offs = 0; + if (l_ve[i] > -_Inf) { + sp_set_val(_qp->C, ridx_ive[i], j, 0.0); + offs = 1; + } + if (u_ve[i] < _Inf) + sp_set_val(_qp->C, ridx_ive[i] + offs, j, 0.0); + } + } + } + + // Hessian + + if (_hela_init) { + for (k = 0; k < NHI; k++) { + ijidx_end = IPRNHI[k + 1] - 1; + idx_end = IPRHI[k + 1] - 1; + idx = IPRHI[k] - 1; + for (iidx = IPRNHI[k] - 1; iidx < ijidx_end; iidx++) { + i = IRNHI[iidx] - 1; + for (jidx = IPRNHI[k] - 1; jidx < ijidx_end; jidx++) { + j = IRNHI[jidx] - 1; + if (i <= j) { + sp_add_val(_qp->Q, i, j, _H->ve[idx]); + idx++; + } + } + } + } + } + +#else + + fbool GRLAGF = 0; + Real *J_ve; + int j, idx; + + sv_mlt(1.0/_fscale, _v, _v); + if (_hela_init || _hela) { + (*_csgrsh_p)(&_N, &_M, _x0->ve, &GRLAGF, &_M, _v->ve, + &_NNZJ, &_NNZJMAX, _J->ve, _INDVAR, _INDFUN, + &_NNZH, &_NNZHMAX, _H->ve, _IRNSH, _ICNSH); + } + else { + (*_csgr_p)(&_N, &_M, &GRLAGF, &_M, _v->ve, _x0->ve, + &_NNZJ, &_NNZJMAX, _J->ve, _INDVAR, _INDFUN); + } + sv_mlt(_fscale, _v, _v); + + v_zero(_qp->c); + l_ve = _cns_lb->ve; + u_ve = _cns_ub->ve; + ridx_ive = _cns_ridx->ive; + J_ve = _J->ve; + for (idx = 0; idx < _NNZJ; idx++) { + i = _INDFUN[idx] - 1; + j = _INDVAR[idx] - 1; + if (i == -1) + _qp->c[j] = _fscale * J_ve[idx]; + if (i >= 0) { + if (l_ve[i] == u_ve[i]) + sp_set_val(_qp->A, ridx_ive[i], j, J_ve[idx]); + else { + offs = 0; + if (l_ve[i] > -_Inf) { + sp_set_val(_qp->C, ridx_ive[i], j, J_ve[idx]); + offs = 1; + } + if (u_ve[i] < _Inf) + sp_set_val(_qp->C, ridx_ive[i] + offs, j, -J_ve[idx]); + } + } + } + + if (_hela_init) { + for (idx = 0; idx < _NNZH; idx++) { + i = _IRNSH[idx] - 1; + j = _ICNSH[idx] - 1; + if (j >= i) + sp_set_val(_qp->Q, i, j, _H->ve[idx]); + else + sp_set_val(_qp->Q, j, i, _H->ve[idx]); + } + } +#endif + + init_x(); + + _fbd_evals = 1; +} + +//------------------------------------------------------------------------- +void Prg_CUTE::init_x() +{ + v_copy(_x0, _x); +} + +//------------------------------------------------------------------------- +void Prg_CUTE::update_bounds(const Real *val_ve, + const Real *l_ve, const Real *u_ve, int n, + const int *ridx_ive) +{ + int i, offs; + Real *b_ve, *d_ve; + + b_ve = _qp->b->ve; + d_ve = _qp->d->ve; + + for (i=0; i -_Inf) { + d_ve[ridx_ive[i]] = val_ve[i] - l_ve[i]; + offs = 1; + } + if (u_ve[i] < _Inf) + d_ve[ridx_ive[i] + offs] = u_ve[i] - val_ve[i]; + } + } +} + +//------------------------------------------------------------------------- +void Prg_CUTE::update_fbd() +{ + if (!_cfn_p) + error(E_NULL, "Prg_CUTE::update_fbd"); + + (*_cfn_p)(&_N, &_M, _x->ve, &_f, &_M, _cns->ve); + + _f *= _fscale; + update_bounds(_x->ve, _var_lb->ve, _var_ub->ve, _N, _var_ridx->ive); + update_bounds(_cns->ve, _cns_lb->ve, _cns_ub->ve, _M, _cns_ridx->ive); + + _fbd_evals++; +} + +//------------------------------------------------------------------------- +void Prg_CUTE::update(const VECP y, const VECP z) +{ + freal F; + fbool GRLAGF = 0; + int i, i_end, j, idx, offs; + int *ridx_ive; + Real *l_ve, *u_ve, *v_ve, *J_ve; + SPROW *row; + int newel_h, newel_j; + + update_fbd(); + _fbd_evals--; + + if (!(const VEC *)y || !(const VEC *)z) + error(E_NULL, "Prg_CUTE::update"); + + if (!_csgr_p || !_csgrsh_p) + error(E_NULL, "Prg_CUTE::update"); + + ridx_ive = _cns_ridx->ive; + l_ve = _cns_lb->ve; + u_ve = _cns_ub->ve; + v_ve = _v->ve; + for (i=0; i<_M; i++) { + idx = ridx_ive[i]; + if (l_ve[i] == u_ve[i]) + v_ve[i] = y->ve[idx]; + else { + offs = 0; + v_ve[i] = 0.0; + if (l_ve[i] > -_Inf) { + v_ve[i] -= z->ve[idx]; + offs = 1; + } + if (u_ve[i] < _Inf) + v_ve[i] += z->ve[idx + offs]; + } + } + + sv_mlt(1.0/_fscale, _v, _v); + if (_hela) { + (*_csgrsh_p)(&_N, &_M, _x->ve, &GRLAGF, &_M, _v->ve, + &_NNZJ, &_NNZJMAX, _J->ve, _INDVAR, _INDFUN, + &_NNZH, &_NNZHMAX, _H->ve, _IRNSH, _ICNSH); + sv_mlt(_fscale, _H, _H); + } + else { + (*_csgr_p)(&_N, &_M, &GRLAGF, &_M, _v->ve, _x->ve, + &_NNZJ, &_NNZJMAX, _J->ve, _INDVAR, _INDFUN); + } + sv_mlt(_fscale, _v, _v); + + row = _qp->A->row + _me_lin; + i_end = _qp->A->m; + for (i = _me_lin; i < i_end; i++, row++) + sprow_zero(row); + + row = _qp->C->row + _m_lin; + i_end = _qp->C->m; + for (i = _m_lin; i < i_end; i++, row++) + sprow_zero(row); + + newel_j = 0; + + Real *c_ve; + v_zero(_qp->c); + c_ve = _qp->c->ve; + l_ve = _cns_lb->ve; + u_ve = _cns_ub->ve; + ridx_ive = _cns_ridx->ive; + J_ve = _J->ve; + for (idx = 0; idx < _NNZJ; idx++) { + i = _INDFUN[idx] - 1; + j = _INDVAR[idx] - 1; + if (i == -1) + c_ve[j] = _fscale * J_ve[idx]; + if (i >= 0) { + if (l_ve[i] == u_ve[i]) + newel_j |= sp_update_val(_qp->A, ridx_ive[i], j, J_ve[idx]); + else { + offs = 0; + if (l_ve[i] > -_Inf) { + newel_j |= sp_update_val(_qp->C, ridx_ive[i], j, J_ve[idx]); + offs = 1; + } + if (u_ve[i] < _Inf) + newel_j |= sp_update_val(_qp->C, ridx_ive[i] + offs, j, -J_ve[idx]); + } + } + } + + newel_h = 0; + if (_hela) { + sp_zero(_qp->Q); + for (idx = 0; idx < _NNZH; idx++) { + i = _IRNSH[idx] - 1; + j = _ICNSH[idx] - 1; + if (j >= i) + newel_h |= sp_update_val(_qp->Q, i, j, _H->ve[idx]); + else + newel_h |= sp_update_val(_qp->Q, j, i, _H->ve[idx]); + } + } + + if (newel_j) + warning(WARN_UNKNOWN, + "Prg_CUTE::update: Jacobian sparsity structure changed"); + if (newel_h) + warning(WARN_UNKNOWN, + "Prg_CUTE::update: Hessian sparsity structure changed"); + + extern Tcl_Interp *theInterp; + if (newel_j || newel_h) { + init_x(); + Tcl_Eval(theInterp, "sqp_init; sqp_qp_update"); + } +} + +//------------------------------------------------------------------------- +int Prg_CUTE::write_soln(int argc, char *argv[], char **) +{ + char header[61]; + fint idum = 0; + freal rdum = 0.0; + extern const char *Hqp_Version; + + if (!_cwrtsn_p) + error(E_NULL, "Prg_CUTE::write_soln"); + + sprintf(header, "HQP %-4.4s: ", Hqp_Version); + if (argc > 1) + sprintf(header + 10, "%-50.50s", argv[argc - 1]); + else + sprintf(header + 10, "%-50.50s", ""); + + if (argc > 1 && strncmp(argv[1], "-nosol", 6) == 0) + (*_cwrtsn_p)(&idum, &idum, header, &rdum, &rdum, &rdum); + else + (*_cwrtsn_p)(&_N, &_M, header, &_f, _x->ve, _v->ve); + + return IF_OK; +} + + +//========================================================================= diff --git a/hqp/Prg_CUTE.h b/hqp/Prg_CUTE.h new file mode 100644 index 0000000..bcf3109 --- /dev/null +++ b/hqp/Prg_CUTE.h @@ -0,0 +1,158 @@ +/* + * Prg_CUTE.h -- + * - convert a CUTE problem into a Hqp_SqpProgram + * + * rf, 10/27/95 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Prg_CUTE_H +#define Prg_CUTE_H + +#include "Hqp_SqpProgram.h" + +/* + * define types for external functions, + * that have to be provided for a problem + */ + +#ifndef fint +#define fint int +#endif + +#ifndef freal +#define freal double +#endif + +#ifndef fbool +#define fbool int +#endif + +typedef void +(csize_t)(fint *N, fint *M, fint *NNZJ, fint *NNZH); +typedef void +(cinit_t)(fint *N, fint *M, freal *X0, freal *BL, freal *BU, freal *INF, + fbool *EQUATN, fbool *LINEAR, freal *V0, freal *CL, freal *CU, + fbool *EFIRST, fbool *LFIRST, fbool *NVFRST); +typedef void +(cfn_t)(const fint *N, const fint *M, const freal *X, + freal *F, const fint *LC, freal *C); +typedef void +(csgr_t)(const fint *N, const fint *M, const fbool *GRLAGF, + const fint *LV, const freal *V, const freal *X, + fint *NNZSCJ, const fint *LSCJAC, freal *SCJAC, + fint *INDVAR, fint *INDFUN); +typedef void +(csgrsh_t)(const fint *N, const fint *M, const freal *X, const fbool *GRLAGF, + const fint *LV, const freal *V, + fint *NNZSCJ, const fint *LSCJAC, freal *SCJAC, + fint *INDVAR, fint *INDFUN, + fint *NNZSH, const fint *LSH, freal *SH, + fint *IRNSH, fint *ICNSH); +typedef void +(csgreh_t)(const fint *N, const fint *M, const freal *X, const fbool *GRLAGF, + const fint *LV, const freal *V, + fint *NNZSCJ, const fint *LSCJAC, freal *SCJAC, + fint *INDVAR, fint *INDFUN, fint *NE, fint *IRNHI, + const fint *LIRNHI, const fint *LE, fint *IPRNHI, + freal *HI, const fint *LHI, fint *IPRHI, const fbool *BYROWS); +typedef void +(cwrtsn_t)(const fint *N, const fint *M, const char *header, + const freal *F, const freal *X, const freal *V); + +/* + * class declaration + */ + +class Prg_CUTE: public Hqp_SqpProgram { + + protected: + // pointers to external provided functions + csize_t *_csize_p; + cinit_t *_cinit_p; + cfn_t *_cfn_p; + csgr_t *_csgr_p; + csgrsh_t *_csgrsh_p; + csgreh_t *_csgreh_p; + cwrtsn_t *_cwrtsn_p; + + // variables for the CUTE interface + fint _N; + fint _M; + fint _NNZJ; + fint _NNZH; + fint _NNZJMAX; + fint _NNZHMAX; + fint *_INDVAR; + fint *_INDFUN; + fint *_IRNSH; + fint *_ICNSH; + + double _fscale;// scaling of the objective function + VEC *_x0; // initial variable values + VEC *_var_lb; // lower bounds for variables + VEC *_var_ub; // upper bounds for variables + VEC *_cns_lb; // lower bounds for constraints + VEC *_cns_ub; // upper bounds for constraints + Real _Inf; // number used for Infinity + + VEC *_cns; // values of constraints + VEC *_J; // elements of sparse Jacobian + VEC *_H; // elements of sparse Hessian + VEC *_v; // lagrangian multipliers + + // store for each variable and constraint corresponding row in A or C + IVEC *_var_ridx; + IVEC *_cns_ridx; + void parse_bounds(const Real *l_ve, const Real *u_ve, int n, + int *ridx_ive, int *me, int *m); + void update_bounds(const Real *val_ve, + const Real *l_ve, const Real *u_ve, int n, + const int *ridx_ive); + + // store number of linear constraints, that come first in A and C + int _me_lin; + int _m_lin; + + bool _hela; // update Lagrangian Hessian + bool _hela_init; // initialize Lagrangian Hessian + int _fbd_evals; + + public: + + Prg_CUTE(); + ~Prg_CUTE(); + + void setup(); + void init_x(); + + void update_fbd(); + void update(const VECP y, const VECP z); + + int write_soln(IF_DEF_ARGS); // write the solution + + char *name() {return "CUTE";} +}; + + +#endif + + diff --git a/hqp/Prg_CUTE_ST.C b/hqp/Prg_CUTE_ST.C new file mode 100644 index 0000000..500e0e1 --- /dev/null +++ b/hqp/Prg_CUTE_ST.C @@ -0,0 +1,1225 @@ +/* + * Prg_CUTE_ST.C -- class definition + * + * rf, 2/10/97 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +//#define RECALCULATE_CNS 1 +//#define BLOW_OUTPUT 1 + +#include +#include +#include +#include + +#include "Prg_CUTE_ST.h" +#include "Hqp_Program.h" + +#include +#include +#include +#include +#include + +extern "C" { + csize_t csize_; + cinit_t cinit_; + cfn_t cfn_; + csgr_t csgr_; + cscifg_t cscifg_; + csgreh_t csgreh_; + cwrtsn_t cwrtsn_; +} + +typedef If_Method If_Cmd; + +IF_CLASS_DEFINE("CUTE_ST", Prg_CUTE_ST, Hqp_SqpProgram); + +//------------------------------------------------------------------------- +static int cmp_int(const int *i1, const int *i2) +{ + return *i1 - *i2; +} + +//------------------------------------------------------------------------- +/* + * sp_add_val: + * add val to an existing entry + */ +int sp_add_val(SPMAT *A, int i, int j, Real val) +{ + SPROW *row; + int idx; + + if ( A == SMNULL ) + error(E_NULL,"sp_add_val"); + if ( i < 0 || i >= A->m || j < 0 || j >= A->n ) + error(E_SIZES,"sp_add_val"); + + row = A->row+i; + idx = sprow_idx(row, j); + if ( idx >= 0 ) { + row->elt[idx].val += val; + return 0; + } + else { + sp_set_val(A, i, j, val); + return 1; + } +} + +//------------------------------------------------------------------------- +Prg_CUTE_ST::Prg_CUTE_ST() +{ + _csize_p = NULL; + _cinit_p = NULL; + _cfn_p = NULL; + _csgr_p = NULL; + _cscifg_p = NULL; + _csgreh_p = NULL; + _cwrtsn_p = NULL; + + _xscale = 1.0; + _fscale = 1.0; + _x0 = v_resize(v_get(1), 0); + _xs = v_resize(v_get(1), 0); + _var_lb = v_resize(v_get(1), 0); + _var_ub = v_resize(v_get(1), 0); + _cns_lb = v_resize(v_get(1), 0); + _cns_ub = v_resize(v_get(1), 0); + _cns = v_resize(v_get(1), 0); + _J = v_resize(v_get(1), 0); + _H = v_resize(v_get(1), 0); + _v = v_resize(v_get(1), 0); + _var_ridx = iv_resize(iv_get(1), 0); + _cns_ridx = iv_resize(iv_get(1), 0); + _h2s = iv_resize(iv_get(1), 0); + _s2h0 = iv_resize(iv_get(1), 0); + _s2h = iv_resize(iv_get(1), 0); + _s2h_stage = iv_resize(iv_get(1), 0); + _s2h_begin = iv_resize(iv_get(1), 0); + _equ_idx0 = iv_resize(iv_get(1), 0); + _equ_idx1 = iv_resize(iv_get(1), 0); + _grp_stage = iv_resize(iv_get(1), 0); + _cns_stage = iv_resize(iv_get(1), 0); + + _fbd_evals = 0; + _nstages = 0; + _NNZJ = 0; + _NNZJMAX = 0; + _INDVAR = NULL; + _INDFUN = NULL; + + _NHI = 0; + _NEL = 0; + _NHIMAX = 0; + _NELMAX = 0; + _IPRHI = NULL; + _IRNHI = NULL; + _IPRNHI = NULL; + _iprhi = iv_resize(iv_get(1), 0); + _irnhi = iv_resize(iv_get(1), 0); + _iprnhi = iv_resize(iv_get(1), 0); + + _hela = false; + _hela_init = true; + _stretch = true; + _ifList.append(new If_Float("prg_xscale", &_xscale)); + _ifList.append(new If_Float("prg_fscale", &_fscale)); + _ifList.append(new If_Bool("prg_hela", &_hela)); + _ifList.append(new If_Bool("prg_hela_init", &_hela_init)); + _ifList.append(new If_Bool("prg_stretch", &_stretch)); + _ifList.append(new If_Int("prg_fbd_evals", &_fbd_evals)); + _ifList.append(new If_Int("prg_N", &_N)); + _ifList.append(new If_Int("prg_NEL", &_NEL)); + _ifList.append(new If_Int("prg_K", &_nstages)); + _ifList.append(new If_Cmd("prg_write_soln", &Prg_CUTE_ST::write_soln, this)); +} + +//------------------------------------------------------------------------- +Prg_CUTE_ST::~Prg_CUTE_ST() +{ + v_free(_x0); + v_free(_xs); + v_free(_var_lb); + v_free(_var_ub); + v_free(_cns_lb); + v_free(_cns_ub); + v_free(_cns); + v_free(_J); + v_free(_H); + v_free(_v); + iv_free(_grp_stage); + iv_free(_cns_stage); + iv_free(_var_ridx); + iv_free(_cns_ridx); + iv_free(_h2s); + iv_free(_s2h0); + iv_free(_s2h); + iv_free(_s2h_stage); + iv_free(_s2h_begin); + iv_free(_equ_idx0); + iv_free(_equ_idx1); + iv_free(_iprnhi); + iv_free(_irnhi); + iv_free(_iprhi); + + delete [] _INDVAR; + delete [] _INDFUN; + delete [] _IPRHI; + delete [] _IRNHI; + delete [] _IPRNHI; +} + +//------------------------------------------------------------------------- +void Prg_CUTE_ST::parse_bounds(const VECP lb, const VECP ub, int n, + IVECP ridx, int &me, int &m) +{ + int i; + + for (i=0; i -_Inf) + ridx[i] = m++; + if (ub[i] < _Inf) { + if (ridx[i] == -1) + ridx[i] = m++; + else + m++; + } + } + } +} + +//------------------------------------------------------------------------- +static int shared_vars(int *v1, int n1, int *v2, int n2) +{ + assert(n1 <= n2); + + int i1, i2; + int shared = 0; + + for (i1 = 0, i2 = 0; i1 < n1 && i2 < n2; i1++) { + while (v1[i1] > v2[i2] && i2 < n2) i2++; + if (i2 < n2 && v1[i1] == v2[i2]) { + shared++; + } + } + return shared; +} + +//------------------------------------------------------------------------- +static bool is_subset(int *v1, int n1, int *v2, int n2) +{ + return (shared_vars(v1, n1, v2, n2) == n1); +} + +//------------------------------------------------------------------------- +static bool is_resembling(int *v1, int n1, int *v2, int n2) +{ + int sv = shared_vars(v1, n1, v2, n2); + return (sv == n1 || sv >= n1 - 1 && n1 > 1); +} + +//------------------------------------------------------------------------- +void Prg_CUTE_ST::setup() +{ + int n, me, m; // number of variables, equality, and inequality constr. + int i, offs; + fbool *EQUATN, *LINEAR; + fbool EFIRST = 0; + fbool LFIRST = 0; + fbool NVFRST = 0; + + /* + * bind CUTE procedures + */ + + _csize_p = (csize_t*)&csize_; + _cinit_p = (cinit_t*)&cinit_; + _cfn_p = (cfn_t*)&cfn_; + _csgr_p = (csgr_t*)&csgr_; +#ifdef RECALCULATE_CNS + _cscifg_p = (cscifg_t*)&cscifg_; +#endif + _csgreh_p = (csgreh_t*)&csgreh_; + _cwrtsn_p = (cwrtsn_t*)&cwrtsn_; + + /* + * get the problem size; allocate and initialize variables + */ + + (*_csize_p)(&_N, &_M, &_NNZJMAX, &_NHIMAX); + + _NELMAX = _NHIMAX / 2; // number of Hessian elements (blocks) + + // allocate maximal dimensions + delete [] _INDVAR; + delete [] _INDFUN; + delete [] _IPRHI; + delete [] _IRNHI; + delete [] _IPRNHI; + + v_resize(_J, _NNZJMAX); + _INDVAR = new fint [_NNZJMAX]; + _INDFUN = new fint [_NNZJMAX]; + v_resize(_H, _NHIMAX); + _IPRHI = new fint [_NELMAX]; + _IRNHI = new fint [_NHIMAX]; + _IPRNHI = new fint [_NELMAX]; + + v_resize(_x0, _N); + v_resize(_var_lb, _N); + v_resize(_var_ub, _N); + v_resize(_v, _M); + v_resize(_cns_lb, _M); + v_resize(_cns_ub, _M); + EQUATN = new fbool [_M]; + LINEAR = new fbool [_M]; + + (*_cinit_p)(&_N, &_M, _x0->ve, _var_lb->ve, _var_ub->ve, &_Inf, + EQUATN, LINEAR, _v->ve, _cns_lb->ve, _cns_ub->ve, + &EFIRST, &LFIRST, &NVFRST); + + // resize to actual dimensions + _x0->dim = _N; + _var_lb->dim = _N; + _var_ub->dim = _N; + _v->dim = _M; + _cns_lb->dim = _M; + _cns_ub->dim = _M; + v_resize(_xs, _N); + iv_resize(_var_ridx, _N); + iv_resize(_cns_ridx, _M); + v_resize(_cns, _M); + + sv_mlt(_xscale, _var_lb, _var_lb); + sv_mlt(_xscale, _var_ub, _var_ub); + if (_xscale > 1.0) + _Inf *= _xscale; + + me = 0; + m = 0; + parse_bounds(_var_lb, _var_ub, _N, _var_ridx, me, m); + _me_bnd = me; + _m_lin = m; + parse_bounds(_cns_lb, _cns_ub, _M, _cns_ridx, me, m); + + /* + * evaluate csgreh_ to obtain Jacobian and Hessian structure + */ + + fbool GRLAGF = 0; + fbool BYROWS = 1; + int j, k, idx; + int iidx, jidx, ijidx_end; + int *ip, *jp; + VECP qp_c; + + (*_csgreh_p)(&_N, &_M, _x0->ve, &GRLAGF, &_M, _v->ve, + &_NNZJ, &_NNZJMAX, _J->ve, _INDVAR, _INDFUN, + &_NEL, _IRNHI, &_NHIMAX, + &_NELMAX, _IPRNHI, _H->ve, &_NHIMAX, _IPRHI, &BYROWS); + + _J->dim = _NNZJ; + _H->dim = _IPRHI[_NEL] - 1; + n = _IPRNHI[_NEL] - 1; + + sv_mlt(1.0/_xscale, _J, _J); + sv_mlt(1.0/_xscale/_xscale, _H, _H); + + /* + * assign nonlinear groups to stages + */ + +#ifdef DEBUG + fprintf(stderr, "Sorting indices,\n"); + fflush(stderr); +#endif + + // initialize sorted pointers and indizes for finite-element Hessian + iv_resize(_iprhi, _NEL); + iv_resize(_iprnhi, _NEL + 1); + iv_resize(_irnhi, n); + iv_resize(_grp_stage, _NEL); + + // sort the groups with decreasing size + // (use _grp_stage as storage and _iprhi for the size of each group) + for (k = 0; k < _NEL; k++) { + _iprhi[k] = _IPRNHI[k + 1] - _IPRNHI[k]; + _grp_stage[k] = k; + } + + k = 1; + while (k < _NEL) { + if (_iprhi[k] > _iprhi[k - 1]) { + idx = _iprhi[k]; + _iprhi[k] = _iprhi[k-1]; + _iprhi[k-1] = idx; + idx = _grp_stage[k]; + _grp_stage[k] = _grp_stage[k-1]; + _grp_stage[k-1] = idx; + k -= (k > 1)? 1: 0; + } + else + k++; + } + + idx = 0; + for (k = 0; k < _NEL; k++) { + + // copy indizes + _iprnhi[k] = idx; + ijidx_end = _IPRNHI[_grp_stage[k] + 1] - 1; + for (iidx = _IPRNHI[_grp_stage[k]] - 1; iidx < ijidx_end; iidx++) + _irnhi[idx++] = _IRNHI[iidx] - 1; + + // store sorted _IPRHI in _iprhi + _iprhi[k] = _IPRHI[_grp_stage[k]] - 1; + } + _iprnhi[_NEL] = idx; + + // sort the indizes of each group as required by shared_vars() + + for (k = 0; k < _NEL; k++) { + qsort((void *)(_irnhi->ive + _iprnhi[k]), _iprnhi[k+1] - _iprnhi[k], + sizeof(int), (int (*)(const void *, const void *))cmp_int); + } + +#ifdef DEBUG + fprintf(stderr, "Assigning groups to stages,\n"); + fflush(stderr); +#endif + + // assign the groups to stages + + int koffs, nk, l, loffs, nl; + bool found; + + _nstages = 0; + if (_stretch) { + for (k = 0; k < _NEL; k++) { + koffs = _iprnhi[k]; + nk = _iprnhi[k + 1] - _iprnhi[k]; + found = false; + + // check existing stages + for (l = 0; l < k && !found; l++) { + loffs = _iprnhi[l]; + nl = _iprnhi[l + 1] - _iprnhi[l]; + if (nl <= nk) + found = is_resembling(_irnhi->ive + loffs, nl, + _irnhi->ive + koffs, nk); + else + found = is_resembling(_irnhi->ive + koffs, nk, + _irnhi->ive + loffs, nl); + if (found) + _grp_stage[k] = _grp_stage[l]; + } + if (!found) { + // make up a new stage + _grp_stage[k] = _nstages++; + } + } + } + else { + _nstages = 1; + iv_set(_grp_stage, 0); + } + +#ifdef DEBUG + fprintf(stderr, " Introduced %d stages for %d groups,\n", _nstages, _NEL); + fflush(stderr); +#endif + +#ifdef BLOW_OUTPUT + // print out the stage assignments + for (k = 0; k < _NEL; k++) { + fprintf(stderr, "%3d(%3d):", k, _grp_stage[k]); + ijidx_end = _iprnhi[k + 1]; + for (iidx = _iprnhi[k]; iidx < ijidx_end; iidx++) + fprintf(stderr, "%4d", _irnhi[iidx]); + fprintf(stderr, "\n"); + } +#endif + + IVECP var_stage = iv_get(_N); + iv_resize(_s2h_begin, _N + 1); + iv_resize(_cns_stage, _M); + +#ifdef DEBUG + fprintf(stderr, "Assigning constraints to stages,\n"); + fflush(stderr); +#endif + + // determine the stage of each constraint + // linear constraints are 'stage' -1 + // mark groups of the objective + + IVECP indvar = iv_get(_NNZJ); + IVECP obj_grp = iv_get(_NEL); + iv_set(obj_grp, 1); + for (idx = 0; idx < _NNZJ; idx++) + indvar[idx] = _INDVAR[idx] - 1; + iv_set(_cns_stage, -1); + ijidx_end = 0; + while (ijidx_end < _NNZJ) { + idx = ijidx_end; + j = _INDFUN[idx] - 1; + while (ijidx_end < _NNZJ && _INDFUN[ijidx_end] - 1 == j) + ijidx_end++; + if (j < 0 || LINEAR[j]) { + continue; + } + nl = ijidx_end - idx; + qsort((void *)(indvar->ive + idx), nl, sizeof(int), + (int (*)(const void *, const void *))cmp_int); + found = false; + for (k = 0; k < _NEL && !found; k++) { + nk = _iprnhi[k+1] - _iprnhi[k]; + if (nk <= nl) + found = is_subset(_irnhi->ive + _iprnhi[k], nk, + indvar->ive + idx, nl); + if (found) { + _cns_stage[j] = _grp_stage[k]; + obj_grp[k] = 0; + } + } + } + +#ifdef BLOW_OUTPUT + // print out constraint assignments + ijidx_end = 0; + while (ijidx_end < _NNZJ) { + idx = ijidx_end; + j = _INDFUN[idx] - 1; + if (j == -1) + fprintf(stderr, "%3d(-,-)%3d:", j, -1); + else + fprintf(stderr, "%3d(%d,%d)%3d:", j, EQUATN[j], LINEAR[j], + _cns_stage[j]); + while (ijidx_end < _NNZJ && _INDFUN[ijidx_end] - 1 == j) { + fprintf(stderr, "%4d", _INDVAR[ijidx_end] - 1); + ijidx_end++; + } + fprintf(stderr, "\n"); + } + fprintf(stderr, "obj_grp: "); + iv_foutput(stderr, obj_grp); +#endif + + /* + * allocate and initialize _x and _qp, including sparsity pattern + */ + +#if 1 +#ifdef DEBUG + fprintf(stderr, "Ordering stages,\n"); + fflush(stderr); +#endif + + // order the stages + PERM *order = px_get(_nstages); +#if 0 + SPMAT *SM = sp_get(_nstages, _nstages, 10); + iv_set(var_stage, -1); + for (k = 0; k < _nstages; k++) { + sp_set_val(SM, k, k, 1.0); + for (l = 0; l < _NEL; l++) { + if (_grp_stage[l] != k) + continue; + ijidx_end = _iprnhi[l + 1]; + for (iidx = _iprnhi[l]; iidx < ijidx_end; iidx++) { + i = _irnhi[iidx]; + if (var_stage[i] != k) { + if (var_stage[i] >= 0) { + sp_set_val(SM, min(k, var_stage[i]), max(k, var_stage[i]), 1.0); + } + var_stage[i] = k; + } + } + } + } + sp_symrcm(SM, order); + sp_free(SM); +#else + for (i = 0; i < _nstages; i++) + order->pe[i] = _nstages - i - 1; +#endif + for (i = 0; i < _NEL; i++) + _grp_stage[i] = order->pe[_grp_stage[i]]; + for (i = 0; i < _M; i++) + if (_cns_stage[i] >= 0) + _cns_stage[i] = order->pe[_cns_stage[i]]; + +#ifdef BLOW_OUTPUT + fprintf(stderr, "order: "); + px_foutput(stderr, order); +#endif + + px_free(order); +#endif + +#ifdef DEBUG + fprintf(stderr, "Allocating the QP problem,\n"); + fflush(stderr); +#endif + + // count the number of additional variables + // store their numbers in _s2h_begin + iv_set(_s2h_begin, 0); + iv_set(var_stage, -1); + n = _N; + for (k = 0; k < _nstages; k++) { + for (l = 0; l < _NEL; l++) { + if (_grp_stage[l] != k) + continue; + ijidx_end = _iprnhi[l + 1]; + for (iidx = _iprnhi[l]; iidx < ijidx_end; iidx++) { + i = _irnhi[iidx]; + if (var_stage[i] != k) { + if (var_stage[i] >= 0) { + n++; // additional variable + } + _s2h_begin[i]++; + var_stage[i] = k; + } + } + } + } + // sum up _s2h_begin + // consider linear variables and additional bounds + int m_offs; + m_offs = 0; + offs = 0; + j = 0; + for (i = 0; i < _N; i++) { + nk = _s2h_begin[i]; + if (nk == 0) { + nk = 1; + _s2h_begin[i] = 1; // linear variable + j++; + } + // additional variable bounds + if (_var_lb[i] != _var_ub[i] && _var_ridx[i] >= 0) { + if (_var_lb[i] > -_Inf) + m_offs += nk - 1; + if (_var_ub[i] < _Inf) + m_offs += nk - 1; + } + offs += nk; + _s2h_begin[i] = offs - nk; + } + _s2h_begin[_N] = offs; + m += m_offs; + _m_lin += m_offs; + +#ifdef DEBUG + fprintf(stderr, " %d linear variables,\n", j); + fflush(stderr); +#endif + + offs = n - _N; // number of additional variables and equ. constraints + + me += offs; + _me_lin = _me_bnd + offs; + + // shift indices for general constraints + for (i = 0; i < _M; i++) { + if (_cns_lb[i] == _cns_ub[i]) + _cns_ridx[i] += offs; + else + _cns_ridx[i] += m_offs; + } + + _qp->resize(n, me, m, 10, 10, 2); + _x = v_resize(_x, n); + + iv_resize(_h2s, n); + iv_resize(_equ_idx0, offs); + iv_resize(_equ_idx1, offs); + iv_resize(_s2h, n); + iv_resize(_s2h_stage, n); + iv_resize(_s2h0, _N); + +#ifdef DEBUG + fprintf(stderr, "Initializing additional variables,\n"); + fflush(stderr); +#endif + + iv_set(var_stage, -1); + iv_set(_s2h0, -1); + j = 0; + offs = 0; + for (k = 0; k < _nstages; k++) { + for (l = 0; l < _NEL; l++) { + if (_grp_stage[l] != k) + continue; + ijidx_end = _iprnhi[l + 1]; + for (iidx = _iprnhi[l]; iidx < ijidx_end; iidx++) { + i = _irnhi[iidx]; + if (var_stage[i] != k) { + if (var_stage[i] >= 0) { + _equ_idx0[offs] = _s2h[_s2h_begin[i]-1]; + _equ_idx1[offs] = j; + sp_set_val(_qp->A, _me_bnd + offs, _equ_idx0[offs], 1.0); + sp_set_val(_qp->A, _me_bnd + offs, _equ_idx1[offs], -1.0); + offs++; + } + _s2h[_s2h_begin[i]] = j; + _s2h_stage[_s2h_begin[i]] = k; + _h2s[j] = i; + if (obj_grp[l]) + _s2h0[i] = j; + j++; + _s2h_begin[i]++; + var_stage[i] = k; + } + else { + if (obj_grp[l]) + _s2h0[i] = _s2h[_s2h_begin[i]-1]; + } + } + } + } + + // indices for variables that appear only linearly + for (i = 0; i < _N; i++) + if (var_stage[i] == -1) { + _s2h[_s2h_begin[i]] = j; + _s2h_stage[_s2h_begin[i]] = 0; + _h2s[j] = i; + j++; + _s2h_begin[i]++; + } + + // correct _s2h_begin by shifting it right + for (i = _N; i > 0; i--) + _s2h_begin[i] = _s2h_begin[i-1]; + _s2h_begin[0] = 0; + +#ifdef DEBUG + fprintf(stderr, "Initializing A and C,\n"); + fflush(stderr); +#endif + +#ifdef BLOW_OUTPUT + // print out variable assignments + for (i = 0; i < _N; i++) { + fprintf(stderr, "%3d:", i); + for (j = _s2h_begin[i]; j < _s2h_begin[i+1]; j++) + fprintf(stderr, "%3d(%3d) ", _s2h[j], _s2h_stage[j]); + fprintf(stderr, "\n"); + } + fprintf(stderr, "_s2h0: "); + iv_foutput(stderr, _s2h0); +#endif + + // fill up _s2h0 for variables that don't ingo into the objective + // and check for overlapping objective groups + for (i = 0; i < _N; i++) + if (_s2h0[i] == -1) + _s2h0[i] = _s2h[_s2h_begin[i]]; + + // reinitialize _var_ridx, _var_lb, _var_ub + + IVECP var_ridx = iv_get(n); + VECP var_lb = v_get(n); + VECP var_ub = v_get(n); + iv_set(var_ridx, -1); + v_set(var_lb, -_Inf); + v_set(var_ub, _Inf); + m_offs = 0; + for (i = 0; i < _N; i++) { + jidx = _s2h_begin[i]; + var_lb[_s2h[jidx]] = _var_lb[i]; + var_ub[_s2h[jidx]] = _var_ub[i]; + var_ridx[_s2h[jidx]] = _var_ridx[i]; + if (_var_ridx[i] >= 0 && _var_lb[i] != _var_ub[i]) { + ijidx_end = _s2h_begin[i+1]; + for (jidx = _s2h_begin[i]; jidx < ijidx_end; jidx++) { + var_lb[_s2h[jidx]] = _var_lb[i]; + var_ub[_s2h[jidx]] = _var_ub[i]; + if (_var_lb[i] > -_Inf) + var_ridx[_s2h[jidx]] = m_offs++; + if (_var_ub[i] < _Inf) { + if (var_ridx[_s2h[jidx]] == -1) + var_ridx[_s2h[jidx]] = m_offs++; + else + m_offs++; + } + } + } + } + v_free(_var_lb); + v_free(_var_ub); + iv_free(_var_ridx); + _var_lb = var_lb; + _var_ub = var_ub; + _var_ridx = var_ridx; + + // variable bounds + + for (i = 0; i < n; i++) { + if (_var_lb[i] == _var_ub[i]) + sp_set_val(_qp->A, _var_ridx[i], i, 1.0); + else { + offs = 0; + if (_var_lb[i] > -_Inf) { + sp_update_val(_qp->C, _var_ridx[i], i, 1.0); + offs = 1; + } + if (_var_ub[i] < _Inf) + sp_update_val(_qp->C, _var_ridx[i] + offs, i, -1.0); + } + } + + /* + * setup the sparsity structure using the starting values + */ + + // general constraints and objective gradient + + qp_c = _qp->c; + v_zero(qp_c); + + for (idx = 0; idx < _NNZJ; idx++) { + i = _INDFUN[idx] - 1; + j = _INDVAR[idx] - 1; + if (i >= 0 && _cns_stage[i] >= 0) { +#if 0 + ijidx_end = _s2h_begin[j+1]; + for (jidx = _s2h_begin[j]; ijidx_end; jidx++) + if (_s2h_stage[jidx] == _cns_stage[i]) { + j = _s2h[jidx]; + break; + } +#else + jp = (int *) + bsearch(&_cns_stage[i], &_s2h_stage[_s2h_begin[j]], + _s2h_begin[j+1] - _s2h_begin[j], sizeof(int), + (int (*)(const void *, const void *))cmp_int); + // there should always be an entry for the stage + if (!jp) + error(E_INTERN, "Prg_CUTE_ST::setup"); + j = _s2h[_s2h_begin[j] + (jp - &_s2h_stage[_s2h_begin[j]])]; +#endif + } + else + j = _s2h0[j]; + if (i == -1) { + qp_c[j] = _fscale * _J[idx]; + } + else { + if (_cns_lb[i] == _cns_ub[i]) + sp_set_val(_qp->A, _cns_ridx[i], j, _J[idx]); + else { + offs = 0; + if (_cns_lb[i] > -_Inf) { + sp_set_val(_qp->C, _cns_ridx[i], j, _J[idx]); + offs = 1; + } + if (_cns_ub[i] < _Inf) + sp_set_val(_qp->C, _cns_ridx[i] + offs, j, -_J[idx]); + } + } + } + +#ifdef DEBUG + fprintf(stderr, "Initializing Q,\n"); + fflush(stderr); +#endif + + // Hessian + + if (_hela_init || _hela) { + for (l = 0; l < _NEL; l++) { + ijidx_end = _iprnhi[l + 1]; + idx = _iprhi[l]; + for (iidx = _iprnhi[l]; iidx < ijidx_end; iidx++) { + for (jidx = iidx; jidx < ijidx_end; jidx++) { + i = _irnhi[iidx]; + j = _irnhi[jidx]; + ip = (int *) + bsearch(&_grp_stage[l], &_s2h_stage[_s2h_begin[i]], + _s2h_begin[i+1] - _s2h_begin[i], sizeof(int), + (int (*)(const void *, const void *))cmp_int); + jp = (int *) + bsearch(&_grp_stage[l], &_s2h_stage[_s2h_begin[j]], + _s2h_begin[j+1] - _s2h_begin[j], sizeof(int), + (int (*)(const void *, const void *))cmp_int); + // there should always be entries for the stage + if (!ip || !jp) + error(E_INTERN, "Prg_CUTE_ST::setup"); + i = _s2h[_s2h_begin[i] + (ip - &_s2h_stage[_s2h_begin[i]])]; + j = _s2h[_s2h_begin[j] + (jp - &_s2h_stage[_s2h_begin[j]])]; + sp_add_val(_qp->Q, min(i, j), max(i, j), _H[idx]); + idx++; + } + } + } + } + + _fbd_evals = 1; + + delete [] EQUATN; + delete [] LINEAR; + iv_free(indvar); + iv_free(var_stage); + iv_free(obj_grp); + + init_x(); + +#ifdef DEBUG + fprintf(stderr, "done.\n\n"); + fflush(stderr); +#endif +} + +//------------------------------------------------------------------------- +void Prg_CUTE_ST::init_x() +{ + int i, n = _x->dim; + for (i = 0; i < n; i++) + _x[i] = _xscale * _x0[_h2s[i]]; +} + +//------------------------------------------------------------------------- +void Prg_CUTE_ST::update_bounds(const VECP val, + const VECP lb, const VECP ub, int n, + const IVECP ridx) +{ + int i, offs; + VECP b, d; + + b = _qp->b; + d = _qp->d; + + for (i = 0; i < n; i++) { + if (lb[i] == ub[i]) + b[ridx[i]] = val[i] - lb[i]; + else { + offs = 0; + if (lb[i] > -_Inf) { + d[ridx[i]] = val[i] - lb[i]; + offs = 1; + } + if (ub[i] < _Inf) + d[ridx[i] + offs] = ub[i] - val[i]; + } + } +} + +//------------------------------------------------------------------------- +void Prg_CUTE_ST::update_fbd() +{ + int i, idx_end, idx, k; + VECP qp_b = _qp->b; + fint I, NNZSGC = 0; + fbool GRAD = 0; + + if (!_cfn_p) + error(E_NULL, "Prg_CUTE_ST::update_fbd"); + +#ifdef RECALCULATE_CNS + if (!_cscifg_p) + error(E_NULL, "Prg_CUTE_ST::update_fbd"); +#endif + + for (i = 0; i < _N; i++) + _xs[i] = 1.0/_xscale * _x[_s2h0[i]]; + + (*_cfn_p)(&_N, &_M, _xs->ve, &_f, &_M, _cns->ve); + + _f *= _fscale; + + update_bounds(_x, _var_lb, _var_ub, _x->dim, _var_ridx); + +#ifdef RECALCULATE_CNS + // recalculate nonlinear constraints + for (k = 0; k < _nstages; k++) { + for (i = 0; i < _N; i++) { + _xs[i] = 1.0/_xscale * _x[_s2h0[i]]; + idx_end = _s2h_begin[i+1]; + for (idx = _s2h_begin[i] + 1; idx < idx_end; idx++) { + if (_s2h_stage[idx] == k) { + _xs[i] = 1.0/_xscale * _x[_s2h[idx]]; + break; + } + } + } + for (i = 0; i < _M; i++) { + if (_cns_stage[i] == k) { + I = i + 1; + (*_cscifg_p)(&_N, &I, _xs->ve, _cns->ve + i, + &NNZSGC, &NNZSGC, NULL, NULL, &GRAD); + } + } + } +#endif + + update_bounds(_cns, _cns_lb, _cns_ub, _M, _cns_ridx); + + // update blow-up's + idx_end = _me_lin - _me_bnd; + for (idx = 0; idx < idx_end; idx++) + qp_b[_me_bnd + idx] = + 1.0/_xscale * (_x[_equ_idx0[idx]] - _x[_equ_idx1[idx]]); + + _fbd_evals++; +} + +//------------------------------------------------------------------------- +void Prg_CUTE_ST::update(const VECP y, const VECP z) +{ + fbool GRLAGF = 0; + fbool BYROWS = 1; + int i, i_end, offs; + int j, k, l, idx, idx_end; + int *ip, *jp; + int iidx, jidx, ijidx_end; + SPROW *row; + int newel_h, newel_j; + VECP qp_c = _qp->c; + double val; + fbool GRAD = 1; + fint I, NNZSGC, NNZSGCMAX; + freal CI; + + update_fbd(); + _fbd_evals--; + + if (!(const VEC *)y || !(const VEC *)z) + error(E_NULL, "Prg_CUTE_ST::update"); + + if (!_csgreh_p || !_csgr_p) + error(E_NULL, "Prg_CUTE_ST::update"); + +#ifdef RECALCULATE_CNS + if (!_cscifg_p) + error(E_NULL, "Prg_CUTE_ST::update"); +#endif + + for (i = 0; i < _N; i++) + _xs[i] = 1.0/_xscale * _x[_s2h0[i]]; + + for (i = 0; i < _M; i++) { + idx = _cns_ridx[i]; + if (_cns_lb[i] == _cns_ub[i]) + _v[i] = y->ve[idx]; + else { + offs = 0; + _v[i] = 0.0; + if (_cns_lb[i] > -_Inf) { + _v[i] -= z->ve[idx]; + offs = 1; + } + if (_cns_ub[i] < _Inf) + _v[i] += z->ve[idx + offs]; + } + } + v_zero(_v); + + if (_hela) { + sv_mlt(1.0/_fscale, _v, _v); + (*_csgreh_p)(&_N, &_M, _xs->ve, &GRLAGF, &_M, _v->ve, + &_NNZJ, &_NNZJMAX, _J->ve, _INDVAR, _INDFUN, + &_NEL, _IRNHI, &_NHIMAX, + &_NELMAX, _IPRNHI, _H->ve, &_NHIMAX, _IPRHI, &BYROWS); + _J->dim = _NNZJ; + _H->dim = _IPRHI[_NEL] - 1; + + sv_mlt(_fscale, _v, _v); + sv_mlt(_fscale, _H, _H); + sv_mlt(1.0/_xscale/_xscale, _H, _H); + } + else { + (*_csgr_p)(&_N, &_M, &GRLAGF, &_M, _v->ve, _xs->ve, + &_NNZJ, &_NNZJMAX, _J->ve, _INDVAR, _INDFUN); + + _J->dim = _NNZJ; + } + sv_mlt(1.0/_xscale, _J, _J); + +#ifdef RECALCULATE_CNS + // recalculate nonlinear constraints + for (k = 0; k < _nstages; k++) { + for (i = 0; i < _N; i++) { + _xs[i] = 1.0/_xscale * _x[_s2h0[i]]; + idx_end = _s2h_begin[i+1]; + for (idx = _s2h_begin[i] + 1; idx < idx_end; idx++) { + if (_s2h_stage[idx] == k) { + _xs[i] = 1.0/_xscale * _x[_s2h[idx]]; + break; + } + } + } + idx_end = 0; + for (i = 0; i < _M; i++) { + idx = idx_end; + while (idx_end < _NNZJ && _INDFUN[idx_end] - 1 == i) + idx_end++; + if (_cns_stage[i] == k) { + I = i + 1; + NNZSGCMAX = idx_end - idx; + (*_cscifg_p)(&_N, &I, _xs->ve, &CI, + &NNZSGC, &NNZSGCMAX, _J->ve + idx, _INDVAR + idx, &GRAD); + } + } + } +#endif + // update Jacobians + + row = _qp->A->row + _me_lin; + i_end = _qp->A->m; + for (i = _me_lin; i < i_end; i++, row++) + sprow_zero(row); + + row = _qp->C->row + _m_lin; + i_end = _qp->C->m; + for (i = _m_lin; i < i_end; i++, row++) + sprow_zero(row); + + newel_j = 0; + v_zero(qp_c); + + for (idx = 0; idx < _NNZJ; idx++) { + val = _J[idx]; + if (val == 0.0) + continue; + i = _INDFUN[idx] - 1; + j = _INDVAR[idx] - 1; + if (i >= 0 && _cns_stage[i] >= 0) { +#if 0 + ijidx_end = _s2h_begin[j+1]; + for (jidx = _s2h_begin[j]; ijidx_end; jidx++) + if (_s2h_stage[jidx] == _cns_stage[i]) { + j = _s2h[jidx]; + break; + } +#else + jp = (int *) + bsearch(&_cns_stage[i], &_s2h_stage[_s2h_begin[j]], + _s2h_begin[j+1] - _s2h_begin[j], sizeof(int), + (int (*)(const void *, const void *))cmp_int); + // there should always be an entry for the stage + if (!jp) + error(E_INTERN, "Prg_CUTE_ST::setup"); + j = _s2h[_s2h_begin[j] + (jp - &_s2h_stage[_s2h_begin[j]])]; +#endif + } + else + j = _s2h0[j]; + if (i == -1) { + qp_c[j] = _fscale * val; + } + else { + if (_cns_lb[i] == _cns_ub[i]) + newel_j |= sp_update_val(_qp->A, _cns_ridx[i], j, val); + else { + offs = 0; + if (_cns_lb[i] > -_Inf) { + newel_j |= sp_update_val(_qp->C, _cns_ridx[i], j, val); + offs = 1; + } + if (_cns_ub[i] < _Inf) + newel_j |= sp_update_val(_qp->C, _cns_ridx[i] + offs, j, -val); + } + } + } + + // Hessian + + newel_h = 0; + if (_hela) { + sp_zero(_qp->Q); + for (l = 0; l < _NEL; l++) { + ijidx_end = _iprnhi[l + 1]; + idx = _iprhi[l]; + for (iidx = _iprnhi[l]; iidx < ijidx_end; iidx++) { + for (jidx = iidx; jidx < ijidx_end; jidx++) { + i = _irnhi[iidx]; + j = _irnhi[jidx]; + ip = (int *) + bsearch(&_grp_stage[l], &_s2h_stage[_s2h_begin[i]], + _s2h_begin[i+1] - _s2h_begin[i], sizeof(int), + (int (*)(const void *, const void *))cmp_int); + jp = (int *) + bsearch(&_grp_stage[l], &_s2h_stage[_s2h_begin[j]], + _s2h_begin[j+1] - _s2h_begin[j], sizeof(int), + (int (*)(const void *, const void *))cmp_int); + // there should always be entries for the stage + if (!ip || !jp) + error(E_INTERN, "Prg_CUTE_ST::setup"); + i = _s2h[_s2h_begin[i] + (ip - &_s2h_stage[_s2h_begin[i]])]; + j = _s2h[_s2h_begin[j] + (jp - &_s2h_stage[_s2h_begin[j]])]; + sp_add_val(_qp->Q, min(i, j), max(i, j), _H[idx]); + idx++; + } + } + } + } + + if (newel_j) + warning(WARN_UNKNOWN, + "Prg_CUTE_ST::update: Jacobian sparsity structure changed"); + if (newel_h) + warning(WARN_UNKNOWN, + "Prg_CUTE_ST::update: Hessian sparsity structure changed"); + + extern Tcl_Interp *theInterp; + if (newel_j || newel_h) { + init_x(); + Tcl_Eval(theInterp, "sqp_init; sqp_qp_update"); + } +} + +//------------------------------------------------------------------------- +int Prg_CUTE_ST::write_soln(int argc, char *argv[], char **) +{ + char header[61]; + fint idum = 0; + freal rdum = 0.0; + extern const char *Hqp_Version; + + if (!_cwrtsn_p) + error(E_NULL, "Prg_CUTE_ST::write_soln"); + + sprintf(header, "HQP %-4.4s: ", Hqp_Version); + if (argc > 1) + sprintf(header + 10, "%-50.50s", argv[argc - 1]); + else + sprintf(header + 10, "%-50.50s", ""); + + if (argc > 1 && strncmp(argv[1], "-nosol", 6) == 0) + (*_cwrtsn_p)(&idum, &idum, header, &rdum, &rdum, &rdum); + else + (*_cwrtsn_p)(&_N, &_M, header, &_f, _xs->ve, _v->ve); + + return IF_OK; +} + + +//========================================================================= diff --git a/hqp/Prg_CUTE_ST.h b/hqp/Prg_CUTE_ST.h new file mode 100644 index 0000000..7379ed1 --- /dev/null +++ b/hqp/Prg_CUTE_ST.h @@ -0,0 +1,176 @@ +/* + * Prg_CUTE_ST.h -- + * - convert a CUTE problem into a Hqp_SqpProgram + * + * rf, 2/10/97 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Prg_CUTE_ST_H +#define Prg_CUTE_ST_H + +#include "Hqp_SqpProgram.h" + +/* + * define types for external functions, + * that have to be provided for a problem + */ + +#ifndef fint +#define fint int +#endif + +#ifndef freal +#define freal double +#endif + +#ifndef fbool +#define fbool int +#endif + +typedef void +(csize_t)(fint *N, fint *M, fint *NNZJ, fint *NNZH); +typedef void +(cinit_t)(fint *N, fint *M, freal *X0, freal *BL, freal *BU, freal *INF, + fbool *EQUATN, fbool *LINEAR, freal *V0, freal *CL, freal *CU, + fbool *EFIRST, fbool *LFIRST, fbool *NVFRST); +typedef void +(cfn_t)(const fint *N, const fint *M, const freal *X, + freal *F, const fint *LC, freal *C); +typedef void +(csgr_t)(const fint *N, const fint *M, const fbool *GRLAGF, + const fint *LV, const freal *V, const freal *X, + fint *NNZSCJ, const fint *LSCJAC, freal *SCJAC, + fint *INDVAR, fint *INDFUN); +typedef void +(cscifg_t)(const fint *N, const fint *I, const freal *X, + freal *CI, fint *NNZSGC, const fint *LSGCI, freal *SGCI, + fint *IVSGCI, fbool *GRAD); +typedef void +(csgreh_t)(const fint *N, const fint *M, const freal *X, const fbool *GRLAGF, + const fint *LV, const freal *V, + fint *NNZSCJ, const fint *LSCJAC, freal *SCJAC, + fint *INDVAR, fint *INDFUN, fint *NE, fint *IRNHI, + const fint *LIRNHI, const fint *LE, fint *IPRNHI, + freal *HI, const fint *LHI, fint *IPRHI, const fbool *BYROWS); +typedef void +(cwrtsn_t)(const fint *N, const fint *M, const char *header, + const freal *F, const freal *X, const freal *V); + +/* + * class declaration + */ + +class Prg_CUTE_ST: public Hqp_SqpProgram { + + protected: + // pointers to external provided functions + csize_t *_csize_p; + cinit_t *_cinit_p; + cfn_t *_cfn_p; + csgr_t *_csgr_p; + cscifg_t *_cscifg_p; + csgreh_t *_csgreh_p; + cwrtsn_t *_cwrtsn_p; + + // variables for the CUTE interface + fint _N; // number of variables + fint _M; // number of constraints + fint _NNZJ; // number of Jacobian non-zeros + fint _NNZJMAX; // dimension of _NNZJ + fint *_INDVAR; // variable index for constraints + fint *_INDFUN; // constraint index + fint _NHI; // number of Hessian entries + fint _NEL; // number of Hessian entries + fint _NHIMAX; // dimension of _HI + fint _NELMAX; // dimension of _IPRHI and _IPRNHI + fint *_IPRHI; // first Hessian entry of each finite-element in _H + fint *_IRNHI; // variable indices of Hessian entries + fint *_IPRNHI; // first variable index of each element in _IRNHI + IVECP _iprhi; // first Hessian entry of each finite-element in _H + IVECP _irnhi; // variable indices of Hessian entries + IVECP _iprnhi; // first variable index of each element in _irnhi + + double _xscale;// scaling of the variables + double _fscale;// scaling of the objective function + VECP _x0; // initial variable values + VECP _xs; // variable vector for SIF + VECP _var_lb; // lower bounds for variables + VECP _var_ub; // upper bounds for variables + VECP _cns_lb; // lower bounds for constraints + VECP _cns_ub; // upper bounds for constraints + double _Inf; // number used for Infinity + + VECP _cns; // values of constraints + VECP _J; // elements of sparse Jacobian + VECP _H; // elements of sparse Hessian + VECP _v; // Lagrangian multipliers + + // store for each variable and constraint the corresponding row in A or C + IVECP _var_ridx; + IVECP _cns_ridx; + void parse_bounds(const VECP lb, const VECP ub, int n, + IVECP ridx, int &me, int &m); + void update_bounds(const VECP val, + const VECP lb, const VECP ub, int n, + const IVECP ridx); + + int _nstages; // number of stages for HQP + int _n; // number of variables for HQP + int _me_bnd; // number of variable bounds + int _me_lin; // number of linear equality constr. that come first in A + int _m_lin; // number of linear inequality constr. that come first in C + + IVECP _h2s; // the SIF index for each HQP variable + IVECP _s2h0; // the HQP index for objective variables + IVECP _s2h; // the HQP index for each SIF variable per stage + IVECP _s2h_stage; // the according stage + IVECP _s2h_begin; // begin of a new variable in _s2h and _s2h_stage + IVECP _equ_idx0; // original variable index for blow up + IVECP _equ_idx1; // introduced variable index for blow up + IVECP _grp_stage; // the stage that belongs to each nonlinear group + IVECP _cns_stage; // the stage that belongs to each constraint + + bool _hela; + bool _hela_init; + bool _stretch; + int _fbd_evals; + + public: + + Prg_CUTE_ST(); + ~Prg_CUTE_ST(); + + void setup(); + void init_x(); + + void update_fbd(); + void update(const VECP y, const VECP z); + + int write_soln(IF_DEF_ARGS); // write the solution + + char *name() {return "CUTE_ST";} +}; + + +#endif + + diff --git a/hqp/bdBKP.C b/hqp/bdBKP.C new file mode 100644 index 0000000..e580452 --- /dev/null +++ b/hqp/bdBKP.C @@ -0,0 +1,388 @@ +/* + * BKP factorization for band matrices + * - reference: J.R.Bunch, L.Kaufman, and B.N.Parlett: + * Decomposition of a Symmetric Matrix, Numer.Math. 27, 95--109 (1976) + * - factorize band matrix A in situ into P'AP = MDM' + * - M is unit lower triangular + * - D is block diagonal with 1x1 or 2x2 blocks + * - let strictly lower part of A untouched + * - P may only be used together with M by BKP-solve routine + * + * rf, 9/9/94 + * + * - restrict the pivot row to be within the band width + * rf, 6/28/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#include "Meschach.h" + +#define alpha 0.6403882032022076 /* = (1+sqrt(17))/8 */ + +static PERM *bd_relief(const BAND *A, PERM *relief) +{ + int i, j, n, lb, ub; + int offs; + Real **A_me; + + if (!A) + error(E_NULL,"bd_relief"); + n = A->mat->n; + lb = A->lb; + ub = A->ub; + A_me = A->mat->me; + if (!relief || (int)relief->size != n) + relief = px_resize(relief, n); + + for (i = 0; i < n; i++) { + j = min(i+ub, n-1); + offs = lb - i + j; + for (; j >= i; j--, offs--) + if (A_me[offs][j] != 0.0) + break; + relief->pe[i] = j + 1; + } + + return relief; +} + + +static void bdBKPchange(BAND *A, int i, int j, PERM *relief) +/* + * - interchange row and col j of A and row and col i + * - A is the reduced matrix of order n-i+1, i < j + */ +{ + Real tmp, **A_me; + int lb, ub2, n; + int offs1, offs2; + int k, k_end; + u_int *re_ve; + + A_me = A->mat->me; + re_ve = relief->pe; + n = A->mat->n; + lb = A->lb; + ub2 = A->ub; + offs1 = re_ve[i]; + offs2 = re_ve[j]; + re_ve[i] = offs2; + re_ve[j] = offs1; + k_end = max(offs1, offs2); + // check storage limits of the band data structure + if (k_end > i + 1 + ub2 || i >= j) + error(E_INTERN, "bdBKPchange"); + k = j + 1; + offs1 = lb + 1; /* - j + k */ + offs2 = lb - i + k; + for (; k < k_end; k++, offs1++, offs2++) { + tmp = A_me[offs1][k]; + A_me[offs1][k] = A_me[offs2][k]; + A_me[offs2][k] = tmp; + } + k = i + 1; + offs1 = lb + 1; /* - i + k */ + offs2 = lb - k + j; + for (; k < j; k++, offs1++, offs2--) { + tmp = A_me[offs1][k]; + A_me[offs1][k] = A_me[offs2][j]; + A_me[offs2][j] = tmp; + re_ve[k] = max((int)re_ve[k], j+1); + } + tmp = A_me[lb][i]; + A_me[lb][i] = A_me[lb][j]; + A_me[lb][j] = tmp; +} + + +BAND *bdBKPfactor(BAND *A, PERM *pivot, PERM *relief) +/* + * - factorize A in situ into P'AP = MDM' + * - P(i+1) == 0 for (i,i+1) is a 2x2 block + * - A->ub is extended for pivoting + * - use relief to store length of rows + */ +{ + int i, ip1, ip2, j, k, n; + int k_end, ub, ub2, lb; + u_int *re_ve; + Real aii, aip1, aiip1, lambda, sigma, tmp; + Real det, s, t; + Real **A_me, *A_diag; + int offs1, offs2; + + if (!A || !pivot || !relief) + error(E_NULL,"bdBKPfactor"); + n = A->mat->n; + if (n != (int)pivot->size || n != (int)relief->size) + error(E_SIZES,"bdBKPfactor"); + + /* + * initialize relief + * extend band matrix for pivoting + */ + + bd_relief(A, relief); + + lb = A->lb; + ub = A->ub; + ub2 = ub * 2; + ub2 = min(ub2, n-1); + A = bd_resize(A, lb, ub2, n); + A_me = A->mat->me; + A_diag = A_me[lb]; + re_ve = relief->pe; + + px_ident(pivot); + for (i = 0; i < n-1;) { + ip1 = i+1; + ip2 = i+2; + aii = fabs(A_diag[i]); + + /* + * find the maximum element in the first column of the reduced + * matrix below the diagonal (go through first row as A is symmetric) + */ + lambda = 0.0; + j = i; + // restrict the pivot row to be within the band width + k_end = min((int)re_ve[i], i + ub); + k = ip1; + offs1 = lb + 1; /* - i + k */ + for (; k < k_end; k++, offs1++) { + tmp = fabs(A_me[offs1][k]); + if (tmp > lambda) { + j = k; + lambda = tmp; + } + } + t = alpha * lambda; + if (aii >= t) + goto onebyone; + + /* + * determine the maximum element in the jth column of the + * reduced matrix off the diagonal + */ + sigma = lambda; + k = ip1; + offs1 = lb - k + j; + for (; k < j; k++, offs1--) { + tmp = fabs(A_me[offs1][j]); + if (tmp > sigma) + sigma = tmp; + } + k_end = re_ve[j]; + k = j + 1; + offs1 = lb + 1; /* - j + k */ + for (; k < k_end; k++, offs1++) { + tmp = fabs(A_me[offs1][k]); + if (tmp > sigma) + sigma = tmp; + } + if (sigma * aii >= t * lambda) + goto onebyone; + if (fabs(A_diag[j]) >= alpha * sigma) { + bdBKPchange(A, i, j, relief); + pivot->pe[i] = j; + goto onebyone; + } + + /* + * do 2x2 pivot + */ + if (j > ip1) { + bdBKPchange(A, ip1, j, relief); + offs1 = lb - i + j; + offs2 = lb + 1; /* - i + ip1 */ + tmp = A_me[offs1][j]; + A_me[offs1][j] = A_me[offs2][ip1]; + A_me[offs2][ip1] = tmp; + } + pivot->pe[i] = j; + pivot->pe[ip1] = 0; + tmp = A_me[lb+1][ip1]; /* lb - i + ip1 */ + det = A_diag[i] * A_diag[ip1] - tmp * tmp; + aiip1 = tmp / det; + aii = A_diag[i] / det; + aip1 = A_diag[ip1] / det; + k_end = max(re_ve[i], re_ve[ip1]); + if (k_end > ip1 + ub2) + error(E_INTERN, "bdBKPfactor"); + j = ip2; + offs1 = lb + j; + for (; j < k_end; j++, offs1++) { + s = - aiip1 * A_me[offs1-ip1][j] + aip1 * A_me[offs1-i][j]; + t = - aiip1 * A_me[offs1-i][j] + aii * A_me[offs1-ip1][j]; + k = j; + offs2 = lb + k; + for (; k < k_end; k++, offs2++) + A_me[offs2-j][k] -= s * A_me[offs2-i][k] + t * A_me[offs2-ip1][k]; + re_ve[j] = max((int)re_ve[j], k_end); + A_me[offs1-i][j] = s; + A_me[offs1-ip1][j] = t; + } + re_ve[i] = max((int)re_ve[i], k_end); + re_ve[ip1] = max((int)re_ve[ip1], k_end); + i = ip2; + continue; + + onebyone: + /* + * do 1x1 pivot + */ + aii = A_diag[i]; + if (aii != 0.0) { + k_end = re_ve[i]; + j = ip1; + offs1 = lb + 1; /* - i + j */ + for (; j < k_end; j++, offs1++) { + s = A_me[offs1][j] / aii; + k = j; + offs2 = lb + k; + for (; k < k_end; k++, offs2++) + A_me[offs2-j][k] -= s * A_me[offs2-i][k]; + re_ve[j] = max((int)re_ve[j], k_end); + A_me[offs1][j] = s; + } + re_ve[i] = max((int)re_ve[i], k_end); + } + i = ip1; + } + + return A; +} + +VEC *bdBKPsolve(const BAND *A, const PERM *pivot, const PERM *relief, + const VEC *b, VEC *x) +/* + * - solve A*x = b after A has been factorized by bdBKPfactor + * - raise an E_SING if A is singular + */ +{ + int i, ii, j, k, ip1; + int n, j_end; + int lb, offs1; + Real det, tmp, save; + Real aiip1, aii, aip1; + Real *x_ve, **A_me; + u_int *p_pe, *re_ve; + + if (!A || !pivot || !b) + error(E_NULL, "bdBKPsolve"); + n = A->mat->n; + if ((int)b->dim != n || (int)pivot->size != n || (int)relief->size != n) + error(E_SIZES, "bdBKPsolve"); + if (!x || (int)x->dim != n) + x = v_resize(x,n); + + p_pe = pivot->pe; + re_ve = relief->pe; + A_me = A->mat->me; + lb = A->lb; + + /* + * solve MDy = b for y, where b is stored in x and store y in x + */ + + x = v_copy(b,x); + x_ve = x->ve; + for (i = 0; i < n-1;) { + ip1 = i+1; + save = x_ve[p_pe[i]]; + if (p_pe[ip1] > 0) { + /* + * 1x1 pivot + */ + x_ve[p_pe[i]] = x_ve[i]; + aii = A_me[lb][i]; + if (aii == 0.0) + error(E_SING, "bdBKPsolve"); + x_ve[i] = save / aii; + j_end = re_ve[i]; + j = ip1; + offs1 = lb + 1; /* - i + j */ + for (; j < j_end; j++, offs1++) + x_ve[j] -= save * A_me[offs1][j]; + i = ip1; + } + else { + /* + * 2x2 pivot + */ + tmp = x_ve[i]; + x_ve[p_pe[i]] = x_ve[ip1]; + aii = A_me[lb][i]; + aip1 = A_me[lb][ip1]; + aiip1 = A_me[lb+1][ip1]; /*lb - i + ip1 */ + det = aii * aip1 - aiip1 * aiip1; + if (det == 0.0) + error(E_SING, "bdBKPsolve"); + x_ve[i] = (tmp * aip1 - save * aiip1) / det; + x_ve[ip1] = (save * aii - tmp * aiip1) / det; + j_end = max(re_ve[i], re_ve[ip1]); + j = i + 2; + offs1 = lb + j; + for (; j < j_end; j++, offs1++) + x_ve[j] -= tmp * A_me[offs1-i][j] + save * A_me[offs1-ip1][j]; + i += 2; + } + } + if (i == n-1) { + aii = A_me[lb][i]; + if (aii == 0.0) + error(E_SING, "bdBKPsolve"); + x_ve[i] /= aii; + i = n - 2; + } + else + i = n - 3; + + /* + * solve M'x = y for x, where y is stored in x + */ + while (i >= 0) { + if (p_pe[i] > 0 || i == 0) + ii = i; /* 1x1 pivot */ + else + ii = i-1; /* 2x2 pivot */ + for (k = ii; k <= i; k++) { + tmp = x_ve[k]; + j_end = re_ve[k]; + j = i + 1; + offs1 = lb - k + j; + for (; j < j_end; j++, offs1++) + tmp -= A_me[offs1][j] * x_ve[j]; + x_ve[k] = tmp; + } + if (i != (int)p_pe[ii]) { + tmp = x_ve[i]; + x_ve[i] = x_ve[p_pe[ii]]; + x_ve[p_pe[ii]] = tmp; + } + i = ii - 1; + } + + return x; +} diff --git a/hqp/hqp_solve.tcl b/hqp/hqp_solve.tcl new file mode 100644 index 0000000..3fde8bb --- /dev/null +++ b/hqp/hqp_solve.tcl @@ -0,0 +1,196 @@ +# +# some Tcl procedures for the Hqp package +# +# rf, 9/8/96 +# +# rf, 4/6/00 +# - added hqp_solve_hot for hot start of SQP solver +# + +proc hqp_exit {reason} { + exit 0 +} + +# +# procedure for defining hqp_logging option +# +proc hqp_logging {{value {}}} { + global hqp_logging + # default value + if {![info exists hqp_logging]} { + set hqp_logging 1 + } + # process value argument + if {$value != {}} { + set hqp_logging $value + } + if {$hqp_logging} { + proc hqp_puts {args} {eval puts $args} + proc hqp_flush {args} {eval flush $args} + } else { + proc hqp_puts {args} {} + proc hqp_flush {args} {} + } + return $hqp_logging +} +# initialize default logging +hqp_logging + +# +# hot start routine +# +proc hqp_solve_hot {{stream stdout}} { + hqp_solve $stream 1 +} + +# +# general solution routine +# +proc hqp_solve {{stream stdout} {hot 0}} { + + global qp_iters + + if {![info exists qp_iters] || [sqp_iter] == 0} { + set qp_iters 0 + } + set nullsteps 0 + + if {[sqp_iter] == 0 || $hot} { + hqp_puts $stream [format "%3s %12s %10s %10s \[%3s %3.3s\] %10s %10s %8s"\ + it obj ||inf|| ||grdL||\ + qp result ||s|| s'Qs stepsize] + } + + while 1 { + + if {$qp_iters == 0} { + if {!$hot} { + # can't re-use higher order information + sqp_qp_update + } + hqp_puts -nonewline $stream [format "%3d %12.6g %10.4g %10.4g " \ + [sqp_iter] [prg_f] [sqp_norm_inf] [sqp_norm_grd_L]] + hqp_flush $stream + } else { + hqp_puts -nonewline $stream [format "%3d %12.6g %10.4g " \ + [sqp_iter] [prg_f] [sqp_norm_inf]] + hqp_flush $stream + + # additional break test as norm_inf changed with taken step + # (Don't use this brake test after cold start, + # as Hessian approximation is not updated anymore! + # This update is useful for subsequent hot starts.) + if {$hot && [sqp_iter] > 0 && [sqp_sQs] >= 0.0 && !$hela_restart} { + if {[sqp_norm_inf] < [sqp_eps] && [qp_result] == "optimal"} { + if {[sqp_sQs] < [expr [sqp_eps]*[sqp_eps]]} break + if {[sqp_iter] > 2} { + if {[sqp_norm_s] < [expr [sqp_eps]*[sqp_norm_x]] + && [sqp_norm_df] < [expr [sqp_eps]*abs([prg_f])] + && [sqp_sQs] < [sqp_eps]} break + } + } + } + + sqp_qp_update + + hqp_puts -nonewline $stream [format "%10.4g " [sqp_norm_grd_L]] + hqp_flush $stream + } + + # test for failed hot start + if {0 && $hot} { + if {$qp_iters == 0} { + set norm_grd_L0 [sqp_norm_grd_L] + } elseif {[sqp_norm_grd_L] > 1.0 && + [expr [sqp_eps]*[sqp_norm_grd_L]] >= $norm_grd_L0} { + hqp_puts "\nRestart cold:" + prg_setup + prg_simulate + sqp_init + return [hqp_solve $stream] + } + } + + # test for bad Hessian + if {[sqp_xQx] < 0.0} { + sqp_hela_restart + set hela_restart 1 + } else { + set hela_restart 0 + } + set xQx_old [sqp_xQx] + + if {[sqp_iter] > 0} { + if {[sqp_norm_inf] < [sqp_eps]} { + if {[sqp_norm_grd_L] < [sqp_eps]} break + } + } + + sqp_qp_solve + incr qp_iters [qp_iter] + + hqp_puts -nonewline $stream [format "\[%3d %3.3s\] " \ + [qp_iter] [qp_result]] + hqp_flush $stream + + if {[qp_iter] == 0} { + hqp_puts $stream "" + error [qp_result] + } + + hqp_puts -nonewline $stream [format "%10.4g %10.4g " \ + [sqp_norm_s] [sqp_sQs]] + hqp_flush $stream + + if {[sqp_sQs] < 0.0} { + sqp_hela_restart + } + + if {[sqp_iter] > 0 && [sqp_sQs] >= 0.0 && !$hela_restart} { + if {[sqp_norm_inf] < [sqp_eps] && [qp_result] == "optimal"} { + if {[sqp_sQs] < [expr [sqp_eps]*[sqp_eps]]} break + if {[sqp_iter] > 2} { + if {[sqp_norm_s] < [expr [sqp_eps]*[sqp_norm_x]] + && [sqp_norm_df] < [expr [sqp_eps]*abs([prg_f])] + && [sqp_sQs] < [sqp_eps]} break + } + } + } + + sqp_step + + hqp_puts $stream [format "%8.3g" [sqp_alpha]] + + if {[qp_iter] >= [qp_max_iters]} { + error subiters + } + if {[sqp_iter] >= [sqp_max_iters]} { + error iters + } + if {[sqp_inf_iters] >= [sqp_max_inf_iters]} { + if {[qp_result] == "suboptimal"} { + error infeasible + } else { + error degenerate + } + } + + if {[sqp_alpha] < 1e-8 + && [sqp_norm_df] < [expr [sqp_eps]*abs([prg_f])]} { + incr nullsteps 1 + } else { + set nullsteps 0 + } + if {$nullsteps > 5} { + error stall + } + + # update quasi-parallel running Tcl stuff + catch {update} + } + + hqp_puts $stream [format "\n%43d qp-it" $qp_iters] + unset qp_iters + + return optimal +} diff --git a/hqp/matBKP.C b/hqp/matBKP.C new file mode 100644 index 0000000..51e1b08 --- /dev/null +++ b/hqp/matBKP.C @@ -0,0 +1,278 @@ +/* + * BKP factorization -- sample implementation + * - reference: J.R.Bunch, L.Kaufman, and B.N.Parlett: + * Decomposition of a Symmetric Matrix, Numer.Math. 27, 95--109 (1976) + * - factorize band matrix A in situ into P'AP = MDM' + * - M is unit lower triangular + * - D is block diagonal with blocks 1x1 and 2x2 + * - let strictly lower part of A untouched + * - P may only be used together with M by BKP-solve routine + * + * rf, 9/9/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +extern "C" { +#include +} + +#define alpha 0.6403882032022076 /* = (1+sqrt(17))/8 */ + +#define A(i,j) A->me[i][j] + +static void interchange(MAT *A, int i, int j) +/* + * - interchange row and col j of A and row and col i + * - i < j + * - A is the reduced matrix of order n-i+1 + */ +{ + Real tmp; + int n; + int k; + + n = A->n; + for (k = j+1; k < n; k++) { + tmp = A(j,k); + A(j,k) = A(i,k); + A(i,k) = tmp; + } + for (k = i+1; k < j; k++) { + tmp = A(i,k); + A(i,k) = A(k,j); + A(k,j) = tmp; + } + tmp = A(i,i); + A(i,i) = A(j,j); + A(j,j) = tmp; +} + + +MAT *matBKPfactor(MAT *A, PERM *pivot) +/* + * - factorize A in situ into P'AP = MDM' + * - P(i+1) == 0 for (i,i+1) is a 2x2 block + */ +{ + int i, ip1, ip2, j, k, n; + Real aii, aip1, aiip1, lambda, sigma, tmp; + Real det, s, t; + + if (!A || !pivot) + error(E_NULL,"matBKPfactor"); + if (A->n != pivot->size) + error(E_SIZES,"matBKPfactor"); + + n = A->n; + px_ident(pivot); + + for (i = 0; i < n-1;) { + ip1 = i+1; + ip2 = i+2; + aii = fabs(A(i,i)); + + /* + * find the maximum element in the first column of the reduced + * matrix below the diagonal (go through first row as A is symmetric) + */ + lambda = 0.0; + j = i; + for (k = ip1; k < n; k++) { + tmp = fabs(A(i,k)); + if (tmp > lambda) { + j = k; + lambda = tmp; + } + } + t = alpha * lambda; + if (aii >= t) + goto onebyone; + + /* + * determine the maximum element in the jth column of the + * reduced matrix off the diagonal + */ + sigma = lambda; + for (k = ip1; k < j; k++) { + tmp = fabs(A(k,j)); + if (tmp > sigma) + sigma = tmp; + } + for (k = j+1; k < n; k++) { + tmp = fabs(A(j,k)); + if (tmp > sigma) + sigma = tmp; + } + if (sigma * aii >= t * lambda) + goto onebyone; + if (fabs(A(j,j)) >= alpha * sigma) { + interchange(A, i, j); + pivot->pe[i] = j; + goto onebyone; + } + + /* + * do 2x2 pivot + */ + if (j > ip1) { + interchange(A, ip1, j); + tmp = A(i,j); + A(i,j) = A(i,ip1); + A(i,ip1) = tmp; + } + pivot->pe[i] = j; + pivot->pe[ip1] = 0; + tmp = A(i,ip1); + det = A(i,i) * A(ip1,ip1) - tmp * tmp; + aiip1 = tmp / det; + aii = A(i,i) / det; + aip1 = A(ip1,ip1) / det; + for (j = ip2; j < n; j++) { + s = - aiip1 * A(ip1,j) + aip1 * A(i,j); + t = - aiip1 * A(i,j) + aii * A(ip1,j); + for (k = j; k < n; k++) + A(j,k) -= s * A(i,k) + t * A(ip1,k); + A(i,j) = s; + A(ip1,j) = t; + } + i = ip2; + continue; + + onebyone: + /* + * do 1x1 pivot + */ + aii = A(i,i); + if (aii != 0.0) { + for (j = ip1; j < n; j++) { + s = A(i,j) / aii; + for (k = j; k < n; k++) + A(j,k) -= s * A(i,k); + A(i,j) = s; + } + } + i = ip1; + } + + return A; +} + +VEC *matBKPsolve(const MAT *A, const PERM *pivot, const VEC *b, VEC *x) +/* + * - solve A*x = b after A has been factorized by matBKPfactor + * - raise an E_SING if A is singular + */ +{ + int i, ii, j, k, ip1; + int n; + Real det, tmp, save; + Real aiip1, aii, aip1; + Real *x_ve; + u_int *p_pe; + + if (!A || !pivot || !b) + error(E_NULL, "matBKPsolve"); + n = A->n; + if ((int)b->dim != n || (int)pivot->size != n) + error(E_SIZES, "matBKPsolve"); + if (!x || (int)x->dim != n) + x = v_resize(x,n); + + p_pe = pivot->pe; + + /* + * solve MDy = b for y, where b is stored in x and store y in x + */ + + x = v_copy(b,x); + x_ve = x->ve; + for (i = 0; i < n-1;) { + ip1 = i+1; + save = x_ve[p_pe[i]]; + if (p_pe[ip1] > 0) { + /* + * 1x1 pivot + */ + x_ve[p_pe[i]] = x_ve[i]; + aii = A(i,i); + if (aii == 0.0) + error(E_SING, "matBKPsolve"); + x_ve[i] = save / aii; + for (j = ip1; j < n; j++) + x_ve[j] -= save * A(i,j); + i = ip1; + } + else { + /* + * 2x2 pivot + */ + tmp = x_ve[i]; + x_ve[p_pe[i]] = x_ve[ip1]; + aii = A(i,i); + aip1 = A(ip1,ip1); + aiip1 = A(i,ip1); + det = aii * aip1 - aiip1 * aiip1; + if (det == 0.0) + error(E_SING, "matBKPsolve"); + x_ve[i] = (tmp * aip1 - save * aiip1) / det; + x_ve[ip1] = (save * aii - tmp * aiip1) / det; + for (j = i+2; j < n; j++) + x_ve[j] -= tmp * A(i,j) + save * A(ip1,j); + i += 2; + } + } + if (i == n-1) { + aii = A(i,i); + if (aii == 0.0) + error(E_SING, "matBKPsolve"); + x_ve[i] /= aii; + i = n - 2; + } + else + i = n - 3; + + /* + * solve M'x = y for x, where y is stored in x + */ + while (i >= 0) { + if (p_pe[i] > 0 || i == 0) + ii = i; /* 1x1 pivot */ + else + ii = i-1; /* 2x2 pivot */ + for (k = ii; k <= i; k++) { + tmp = x_ve[k]; + for (j = i+1; j < n; j++) + tmp -= A(k,j) * x_ve[j]; + x_ve[k] = tmp; + } + if (i != (int)p_pe[ii]) { + tmp = x_ve[i]; + x_ve[i] = x_ve[p_pe[ii]]; + x_ve[p_pe[ii]] = tmp; + } + i = ii - 1; + } + + return x; +} diff --git a/hqp/meschext_ea.C b/hqp/meschext_ea.C new file mode 100644 index 0000000..2fc3eab --- /dev/null +++ b/hqp/meschext_ea.C @@ -0,0 +1,822 @@ +/* + * meschext_ea.C + * - some Meschach add-ons and extensions + * + * E. Arnold 03/07/97 + * + */ + +/* + Copyright (C) 1997--1998 Eckhard Arnold + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#include "meschext_ea.h" + +extern "C" { +#include +#include +} + +//-------------------------------------------------------------------------- +// Prints internal parameters of MAT * data structure. +// E. Arnold 10/08/96 +//-------------------------------------------------------------------------- +void m_output_g(MAT *A) +{ + if ( ! A ) + printf("Matrix %p\n", A); + else { + printf("Matrix %p, m=%d, n=%d, max_m=%d, max_n=%d, ", + A, A->m, A->n, A->max_m, A->max_n); + printf("max_size=%d, me=%p, base=%p\n", + A->max_size, A->me, A->base); + } +} + +//-------------------------------------------------------------------------- +// Prints internal parameters of VEC * data structure. +// E. Arnold 10/08/96 +//-------------------------------------------------------------------------- +void v_output_g(const VEC *A) +{ + if ( ! A ) + printf("Vector %p\n", A); + else + printf("Vector %p, dim=%d, max_dim=%d, ve=%p\n", + A, A->dim, A->max_dim, A->ve); +} + +//-------------------------------------------------------------------------- +// m_copy1 -- copies matrix into new area, +// same as m_copy(), but resizes out to correct size. +// E. Arnold 10/18/96 +//-------------------------------------------------------------------------- +MAT *m_copy1(const MAT *in, MAT *out) +{ + u_int i /* ,j */; + + if ( in==MNULL ) + error(E_NULL,"m_copy1"); + if ( in==out ) + return (out); + if ( out==MNULL || out->m != in->m || out->n != in->n ) + out = m_resize(out,in->m,in->n); + + for ( i=0; i < in->m; i++ ) + MEM_COPY(&(in->me[i][0]),&(out->me[i][0]), + (in->n)*sizeof(Real)); + /* for ( j=0; j < in->n; j++ ) + out->me[i][j] = in->me[i][j]; */ + + return (out); +} + +//-------------------------------------------------------------------------- +// v_copy1 -- copies vector into new area, +// same as v_copy(), but resizes out to correct size. +// E. Arnold 10/18/96 +//-------------------------------------------------------------------------- +VEC *v_copy1(const VEC *in, VEC *out) +{ + /* u_int i,j; */ + + if ( in==VNULL ) + error(E_NULL,"_v_copy1"); + if ( in==out ) + return (out); + if ( out==VNULL || out->dim != in->dim ) + out = v_resize(out,in->dim); + + MEM_COPY(&(in->ve[0]),&(out->ve[0]),(in->dim)*sizeof(Real)); + /* for ( i=0; i < in->dim; i++ ) + out->ve[i] = in->ve[i]; */ + + return (out); +} + +//-------------------------------------------------------------------------- +// v_diag -- get diagonal entries of a matrix +// E. Arnold 02/22/97 +//-------------------------------------------------------------------------- +VEC *v_diag(MAT *A, VEC *C) { + int i, n; + if ( A == MNULL ) + error(E_NULL,"v_diag"); + n = A->m; + if ( n > (int) A->n ) + n = A->n; + C = v_resize(C, n); + for ( i = 0; i < n; i++ ) + v_set_val(C, i, m_entry(A, i, i)); + return C; +} + +//-------------------------------------------------------------------------- +// dm_mlt -- diagonal matrix matrix multiplication +// E. Arnold 02/22/97 +//-------------------------------------------------------------------------- +MAT *dm_mlt(MAT *A, VEC *B, MAT *C) { + int i, j; + double val; + if ( ( A == MNULL ) || ( B == VNULL ) ) + error(E_NULL, "dm_mlt"); + if ( A->m != B->dim ) + error(E_SIZES, "dm_mlt"); + C = m_resize(C, A->m, A->n); + for ( i = 0; i < (int) A->m; i++) { + val = v_entry(B, i); + for ( j = 0; j < (int)A->n; j++ ) + m_set_val(C, i, j, val*m_entry(A, i, j)); + } + return C; +} + +//-------------------------------------------------------------------------- +// md_mlt -- matrix diagonal matrix multiplication +// E. Arnold 02/22/97 +//-------------------------------------------------------------------------- +MAT *md_mlt(MAT *A, VEC *B, MAT *C) { + int i, j; + double val; + if ( ( A == MNULL ) || ( B == VNULL ) ) + error(E_NULL, "md_mlt"); + if ( A->n != B->dim ) + error(E_SIZES, "md_mlt"); + C = m_resize(C, A->m, A->n); + for ( i = 0; i < (int) A->n; i++ ) { + val = v_entry(B, i); + for ( j = 0; j < (int) A->m; j++ ) + m_set_val(C, j, i, val*m_entry(A, j, i)); + } + return C; +} + + +//-------------------------------------------------------------------------- +// m_symm -- make a square matrix symmetric, +// out = 0.5 * (in + in^T) +// E. Arnold 11/27/96 +// 07/03/97 bug: in->m != in->m --> in->m != in->n +//-------------------------------------------------------------------------- +MAT *m_symm(const MAT *in, MAT *out) +{ + u_int i , j; + + if ( in == MNULL ) + error(E_NULL,"m_symm"); + + if ( in->m != in->n ) + error(E_SQUARE,"m_symm"); + + if ( out == MNULL || out->m != in->m || out->n != in->n ) + out = m_resize(out, in->m, in->n); + + for ( i = 0; i < in->m; i++ ) + for ( j = i+1; j < in->m; j++ ) + out->me[i][j] = out->me[j][i] = 0.5*(in->me[i][j]+in->me[j][i]); + + return (out); +} + +//-------------------------------------------------------------------------- +// rel_symm -- check square matrix for symmetry, +// rel_symm = max(max(abs(in-in')./(0.5*(abs(in)+abs(in'))) +// E. Arnold 11/27/96 +// 07/03/97 bug: in->m != in->m --> in->m != in->n +// input argument check +//-------------------------------------------------------------------------- +double rel_symm(const MAT *in) +{ + u_int i , j; + double r; + + if ( in == MNULL ) + error(E_NULL,"rel_symm"); + + if ( in->m != in->n ) + error(E_SQUARE,"rel_symm"); + + for ( r = 0.0, i = 0; i < in->m; i++ ) + for ( j = i+1; j < in->m; j++ ) { + r = max(r, fabs(in->me[i][j]-in->me[j][i])); + } + return (r/m_norm_inf(in)); +} + +//-------------------------------------------------------------------------- +// CHsolve with matrix right hand side. +// E. Arnold 10/18/96 +// 07/03/97 bug: m_resize(C, A->m, B->m) --> +// m_resize(C, A->m, B->n) +// bug: i < B->m --> i < B->n +// input argument check +//-------------------------------------------------------------------------- +MAT *CHsolveM(MAT *A, MAT *B, MAT *C) +{ + static VEC *v1 = VNULL; + u_int i; + + if ( ( A == MNULL ) || ( B == MNULL ) ) + error(E_NULL,"CHsolveM"); + if ( A->m != A->n ) + error(E_SQUARE,"CHsolveM"); + if ( A->m != B->m ) + error(E_SIZES,"CHsolveM"); + + v1 = v_resize(v1, B->m); + MEM_STAT_REG(v1, TYPE_VEC); + C = m_resize(C, A->m, B->n); + + for (i = 0; i < B->n; i++) { + v1 = get_col(B, i, v1); + v1 = CHsolve(A, v1, v1); + C = set_col(C, i, v1); + } + return C; +} + +//-------------------------------------------------------------------------- +// CHsolve with transposed matrix right hand side. +// E. Arnold 10/18/96 +// 07/03/97 input argument check +//-------------------------------------------------------------------------- +MAT *CHsolveMT(MAT *A, MAT *B, MAT *C) +{ + static VEC *v1 = VNULL; + u_int i; + + if ( ( A == MNULL ) || ( B == MNULL ) ) + error(E_NULL,"CHsolveMT"); + if ( A->m != A->n ) + error(E_SQUARE,"CHsolveMT"); + if ( A->m != B->n ) + error(E_SIZES,"CHsolveMT"); + if ( B == C) + error(E_INSITU,"CHsolveMT"); + + v1 = v_resize(v1, B->n); + MEM_STAT_REG(v1, TYPE_VEC); + C = m_resize(C, A->m, B->m); + + for (i = 0; i < B->m; i++) { + v1 = get_row(B, i, v1); + v1 = CHsolve(A, v1, v1); + C = set_col(C, i, v1); + } + return C; +} + +//-------------------------------------------------------------------------- +// BKPsolve with matrix right hand side. +// E. Arnold 10/18/96 +// 07/03/97 input argument check +//-------------------------------------------------------------------------- +MAT *BKPsolveM(MAT *A, PERM *pivot, PERM *blocks, MAT *B, MAT *C) +{ + static VEC *v1 = VNULL; + u_int i; + + if ( ( A == MNULL ) || ( B == MNULL ) ) + error(E_NULL,"BKPsolveM"); + if ( A->m != A->n ) + error(E_SQUARE,"BKPsolveM"); + if ( A->m != B->m ) + error(E_SIZES,"BKPsolveM"); + + v1 = v_resize(v1, B->m); + MEM_STAT_REG(v1, TYPE_VEC); + C = m_resize(C, A->m, B->n); + + for (i = 0; i < B->n; i++) { + v1 = get_col(B, i, v1); + v1 = BKPsolve(A, pivot, blocks, v1, v1); + C = set_col(C, i, v1); + } + return C; +} + +//-------------------------------------------------------------------------- +// BKPsolve with transposed matrix right hand side. +// E. Arnold 10/18/96 +// 07/03/97 input argument check +//-------------------------------------------------------------------------- +MAT *BKPsolveMT(MAT *A, PERM *pivot, PERM *blocks, MAT *B, MAT *C) +{ + static VEC *v1 = VNULL; + u_int i; + + if ( ( A == MNULL ) || ( B == MNULL ) ) + error(E_NULL,"BKPsolveMT"); + if ( A->m != A->n ) + error(E_SQUARE,"BKPsolveMT"); + if ( A->m != B->n ) + error(E_SIZES,"BKPsolveMT"); + if ( B == C) + error(E_INSITU,"BKPsolveMT"); + + v1 = v_resize(v1, B->n); + MEM_STAT_REG(v1, TYPE_VEC); + C = m_resize(C, A->m, B->m); + + for (i = 0; i < B->m; i++) { + v1 = get_row(B, i, v1); + v1 = BKPsolve(A, pivot, blocks, v1, v1); + C = set_col(C, i, v1); + } + return C; +} + +//-------------------------------------------------------------------------- +// LUsolve with matrix right hand side. +// E. Arnold 10/18/96 +// 07/03/97 input argument check +//-------------------------------------------------------------------------- +MAT *LUsolveM(MAT *A, PERM *pivot, MAT *B, MAT *C) +{ + static VEC *v1 = VNULL; + u_int i; + + if ( ( A == MNULL ) || ( B == MNULL ) ) + error(E_NULL,"LUsolveM"); + if ( A->m != A->n ) + error(E_SQUARE,"LUsolveM"); + if ( A->m != B->m ) + error(E_SIZES,"LUsolveM"); + + v1 = v_resize(v1, B->m); + MEM_STAT_REG(v1, TYPE_VEC); + C = m_resize(C, A->m, B->n); + + for (i = 0; i < B->n; i++) { + v1 = get_col(B, i, v1); + v1 = LUsolve(A, pivot, v1, v1); + C = set_col(C, i, v1); + } + return C; +} + +//-------------------------------------------------------------------------- +// LUsolve with transposed matrix right hand side. +// E. Arnold 10/18/96 +// 07/03/97 input argument check +//-------------------------------------------------------------------------- +MAT *LUsolveMT(MAT *A, PERM *pivot, MAT *B, MAT *C) +{ + static VEC *v1 = VNULL; + u_int i; + + if ( ( A == MNULL ) || ( B == MNULL ) ) + error(E_NULL,"LUsolveMT"); + if ( A->m != A->n ) + error(E_SQUARE,"LUsolveMT"); + if ( A->m != B->n ) + error(E_SIZES,"LUsolveMT"); + if ( B == C) + error(E_INSITU,"LUsolveMT"); + + v1 = v_resize(v1, B->n); + MEM_STAT_REG(v1, TYPE_VEC); + C = m_resize(C, A->m, B->m); + + for (i = 0; i < B->m; i++) { + v1 = get_row(B, i, v1); + v1 = LUsolve(A, pivot, v1, v1); + C = set_col(C, i, v1); + } + return C; +} + + +//-------------------------------------------------------------------------- +// GE_QP -- Generalized elimination for quadratic programming. +// E. Arnold 10/08/96 +//-------------------------------------------------------------------------- +void GE_QP(MAT *A, MAT *S, MAT *Z, MAT *PQ, double eps) +{ + static VEC *diag = VNULL; + static PERM *pivot = PNULL; + static MAT *R1 = MNULL; + static MAT *Q = MNULL; + static MAT *R = MNULL; + /* double eps = 1.0e-8; */ + u_int i, m, r; + + if ( ( A == MNULL ) || ( S == MNULL) || ( Z == MNULL ) || ( PQ == MNULL ) ) + error(E_NULL, "GE_QP"); + + m = A->n; + + /* Memory allocation */ + + diag = v_resize(diag, min(A->m, A->n)); + pivot = px_resize(pivot, A->m); + R1 = m_resize(R1, m, m); + Q = m_resize(Q, m, m); + R = m_resize(R, m, m); + + /* Registration of temporary variables */ + + MEM_STAT_REG(diag, TYPE_VEC); + MEM_STAT_REG(pivot, TYPE_PERM); + MEM_STAT_REG(R1, TYPE_MAT); + MEM_STAT_REG(Q, TYPE_MAT); + MEM_STAT_REG(R, TYPE_MAT); + + /* 1st QR factorization: A^T*P = Q*R */ + + PQ = m_transp(A, PQ); + PQ = QRCPfactor(PQ, diag, pivot); + Q = makeQ(PQ, diag, Q); + R = m_resize(R, PQ->m, PQ->n); + R = makeR(PQ, R); + + /* find rank of A and form Z = Q(:,r+1:m) */ + + for (r = 0; r < min(R->m, R->n); r++) + if (fabs(R->me[r][r]) < eps) + break; + // printf("\n r = %d\n Q =", r); m_output(Q); + // printf("\n R ="); m_output(R); + Z = m_resize(Z, Q->m, Q->n-r); + Z = m_move(Q, 0, r, Q->m, Q->n-r, Z, 0, 0); + + /* 2nd QR factorization: R^T=Q1*R1 */ + + R1 = m_transp(R, R1); + R1 = QRfactor(R1, diag); + + /* form PQ = E*Qbar using S as temporary variable */ + + S = m_resize(S, R1->m, R1->m); + S = makeQ(R1, diag, S); + pivot = px_inv(pivot, pivot); + PQ = m_resize(PQ, S->m, S->n); + PQ = px_rows(pivot, S, PQ); + + /* form S = Q(:,1:r)*(R1)^-T */ + R = m_resize(R, R1->m, R1->n); + R = makeR(R1, R); + R1 = m_resize(R1, r, r); + R1 = m_move(R, 0, 0, r, r, R1, 0, 0); + diag = v_resize(diag, r); + S = m_resize(S, m, r); + for (i = 0; i < m; i++) { + diag = get_row(Q, i, diag); + diag->dim = r; + diag = UTsolve(R1, diag, diag, 0.0); + S = set_row(S, i, diag); + } + // m_output(S);m_output(R1);printf("\nm = %d, r = %d\n",m,r); +} + +//-------------------------------------------------------------------------- +// Matrix concatenation by rows C = [A; B]. +// E. Arnold 10/08/96 +//-------------------------------------------------------------------------- +MAT *m_concatc(MAT *A, MAT *B, MAT *C) +{ + int am; + if ( ! A || ! B ) + error(E_NULL, "m_concatc"); + if ( A->n != B->n ) + error(E_SIZES, "m_concatc"); + if ( B == C ) + error(E_INSITU, "m_concatc"); + am = A->m; + C = m_resize(C, am+B->m, A->n); + if ( A != C ) + C = m_move(A, 0, 0, am, A->n, C, 0, 0); + C = m_move(B, 0, 0, B->m, B->n, C, am, 0); + return C; +} + +//-------------------------------------------------------------------------- +// Vector concatenation C = [A; B] +// E. Arnold 10/08/96 +//-------------------------------------------------------------------------- +VEC *v_concat(VEC *A, VEC *B, VEC *C) +{ + u_int adim; + if ( ! A || ! B ) + error(E_NULL, "v_concat"); + if ( B == C ) + error(E_INSITU, "v_concat"); + adim = A->dim; + C = v_resize(C, adim+B->dim); + if ( A != C ) + C = v_move(A, 0, adim, C, 0); + C = v_move(B, 0, B->dim, C, adim); + return C; +} + + +//-------------------------------------------------------------------------- +// C(i) = A(iv(i)) +// E. Arnold 10/08/96 +//-------------------------------------------------------------------------- +VEC *v_move_iv(const VEC *A, const IVEC *iv, VEC *C) +{ + int i; + if ( ! A || ! iv ) + error(E_NULL, "v_move_iv"); + if ( A == C ) + error(E_INSITU, "v_move_iv"); + C = v_resize(C, iv->dim); + for ( i = 0; i < (int) iv->dim; i++) + v_set_val(C, i, v_entry(A, iv_entry(iv, i))); + return C; +} + +//-------------------------------------------------------------------------- +// C(iv(i)) = A(i) +// E. Arnold 10/08/96 +//-------------------------------------------------------------------------- +VEC *v_set_iv(VEC *A, IVEC *iv, VEC *C) +{ + int i; + if ( ! A || ! iv || ! C) + error(E_NULL, "v_set_iv"); + if ( A == C ) + error(E_INSITU, "v_set_iv"); + if ( ! ( A->dim == iv->dim ) ) + error(E_SIZES, "v_set_iv"); + for ( i = 0; i < (int) iv->dim; i++) + v_set_val(C, iv_entry(iv, i), v_entry(A, i)); + return C; +} + +//-------------------------------------------------------------------------- +// Euclidean norm of a SPROW. +// E. Arnold 12/12/96 +//-------------------------------------------------------------------------- +Real sprow_norm2(const SPROW *r) +{ + Real sum = 0.0; + int i; + + if ( r == (SPROW *) NULL ) + error(E_NULL, "sprow_norm2"); + + for ( i = 0; i < r->len; i++ ) + sum += r->elt[i].val*r->elt[i].val; + + return sqrt(sum); +} + +//-------------------------------------------------------------------------- +// Copy a block from sparse matrix src to dense matrix dst using +// an integer vector iv of row indices. +// dst = src(iv(:),j_offs+(1:size(dst,2)) +// E. Arnold 10/07/96 (adapted from (rf) sp_extract_mat) +//-------------------------------------------------------------------------- +void sp_extract_mat_iv(const SPMAT *src, const IVEC *iv, int j_offs, MAT *dst) +{ + SPROW *row; + int i, j; + int i_end, j_end, j_idx; + + if ( ( src == SMNULL ) || ( iv == IVNULL ) || ( dst == MNULL ) ) + error(E_NULL, "sp_extract_mat_iv"); + if ( iv->dim != dst->m ) + error(E_SIZES, "sp_extract_mat_iv"); + m_zero(dst); + + i_end = dst->m; + j_end = dst->n; + for (i=0; irow + iv->ive[i]; + j_idx = sprow_idx(row, j_offs); + if (j_idx < 0) { + if (j_idx == -1) + error(E_BOUNDS,"sp_extract_mat_iv"); + j_idx = -(j_idx + 2); + } + while (j_idx < row->len) { + j = row->elt[j_idx].col - j_offs; + if (j >= j_end) + break; + m_set_val(dst, i, j, row->elt[j_idx].val); + j_idx++; + } + } +} + +//-------------------------------------------------------------------------- +// Block from sparse matrix - dense matrix multiplication. +// E. Arnold 10/19/96 +//-------------------------------------------------------------------------- +MAT *bspm_mlt(const SPMAT *A, int i0, int j0, int m0, const MAT *B, MAT *C) +{ + SPROW *row; + Real val; + int i, j, j_idx; + + if ( ( A == SMNULL ) || ( B == MNULL ) ) + error(E_NULL, "bspm_mlt"); + if ( ( j0+(int)B->m > A->n) || ( i0 + m0 > A->m ) ) + error(E_SIZES, "bspm_mlt"); + if ( B == C ) + error(E_INSITU, "bspm_mlt"); + + if ( ( C == MNULL ) || ( (int)C->m != m0 ) || ( C->n != B->n ) ) + C = m_resize(C, m0, B->n); + + C = m_zero(C); + row = A->row + i0; + for ( i = 0; i < m0; i++, row++) { + j_idx = sprow_idx(row, j0); + if ( j_idx < 0 ) { + if ( j_idx == -1 ) + error(E_BOUNDS,"bspm_mlt"); + j_idx = -(j_idx + 2); + } + while ( j_idx < row->len ) { + j = row->elt[j_idx].col-j0; + if ( j >= (int)B->m ) + break; + val = row->elt[j_idx].val; + // for ( k = 0; k < B->n; k++ ) + // m_add_val(C, i, k, m_entry(B, j, k)*val); + __mltadd__(C->me[i],B->me[j],val,(int) B->n); + j_idx++; + } + } + return C; +} + +//-------------------------------------------------------------------------- +// Dense matrix - block from transposed sparse matrix multiplication. +// E. Arnold 10/24/96 +//-------------------------------------------------------------------------- +MAT *mbsptr_mlt(const MAT *B, const SPMAT *A, int i0, int j0, int n0, MAT *C) +{ + SPROW *row; + Real val; + int i, j, j_idx, k; + + if ( ( A == SMNULL ) || ( B == MNULL ) ) + error(E_NULL, "mbsptr_mlt"); + if ( ( i0+(int)B->n > A->n) || ( j0 + n0 > A->m ) ) + error(E_SIZES, "mbsptr_mlt"); + if ( B == C ) + error(E_INSITU, "msptr_mlt"); + + if ( ( C == MNULL ) || ( (int)C->n != n0 ) || ( C->m != B->m ) ) + C = m_resize(C, B->m, n0); + + C = m_zero(C); + row = A->row + j0; + for ( j = 0; j < n0; j++, row++) { + j_idx = sprow_idx(row, i0); + if ( j_idx < 0 ) { + if ( j_idx == -1 ) + error(E_BOUNDS,"msptr_mlt"); + j_idx = -(j_idx + 2); + } + while ( j_idx < row->len ) { + i = row->elt[j_idx].col-i0; + if ( i >= (int) B->n ) + break; + val = row->elt[j_idx].val; + for ( k = 0; k < (int) B->m; k++ ) + m_add_val(C, k, j, m_entry(B, k, i)*val); + j_idx++; + } + } + return C; +} + +//-------------------------------------------------------------------------- +// Block from sparse matrix - vector multiplication. +// E. Arnold 10/24/96 +//-------------------------------------------------------------------------- +VEC *bspv_mlt(const SPMAT *A, int i0, int j0, int m0, const VEC *B, VEC *C) +{ + SPROW *row; + Real val; + int i, j, j_idx; + + if ( ( A == SMNULL ) || ( B == VNULL ) ) + error(E_NULL, "bspv_mlt"); + if ( ( j0+(int)B->dim > A->n) || ( i0+m0 > A->m ) ) + error(E_SIZES, "bspv_mlt"); + if ( B == C ) + error(E_INSITU, "bspv_mlt"); + + if ( ( C == VNULL ) || ( (int)C->dim != m0 ) ) + C = v_resize(C, m0); + + row = A->row + i0; + for ( i = 0; i < m0; i++, row++) { + j_idx = sprow_idx(row, j0); + if ( j_idx < 0 ) { + if ( j_idx == -1 ) + error(E_BOUNDS,"bspv_mlt"); + j_idx = -(j_idx + 2); + } + val = 0.0; + while ( j_idx < row->len ) { + j = row->elt[j_idx].col-j0; + if ( j >= (int)B->dim ) + break; + val += row->elt[j_idx].val*v_entry(B, j); + j_idx++; + } + v_set_val(C, i, val); + } + return C; +} + +//-------------------------------------------------------------------------- +// Check column indices of a sparse matrix. +// E. Arnold 10/25/96 +//-------------------------------------------------------------------------- +void check_sparse(SPMAT *C) +{ + int i, j, j_idx; + if ( ! C ) + error(E_NULL,"check_sparse"); + for ( i = 0; i < C->m; i++ ) + for ( j = 0; j < C->row[i].len; j++ ) { + j_idx = C->row[i].elt[j].col; + if ( ( j_idx < 0 ) || ( j_idx >= C->n ) ) + printf("check_sparse: i = %d, j = %d, j_idx = %d\n", i, j, j_idx); + } +} + +//-------------------------------------------------------------------------- +// E. Arnold 10/25/96 +// Corrected bug: drow->len = dlen; just after sprow_xpd +//-------------------------------------------------------------------------- +/* + * sp_transp: + * -- build the transpose of sparse matrix A in T + * -- return T + * -- routine may not work in-situ + */ +SPMAT *sp_transp_ea(const SPMAT *A, SPMAT *T) +{ + int n, m; + int i, j_idx; + int slen, dlen; + row_elt *selt, *delt; + SPROW *srow, *drow; + + if (!A) + error(E_NULL, "sp_transp_ea"); + if (A == T) + error(E_INSITU, "sp_transp_ea"); + + n = A->n; + m = A->m; + + if (!T) + T = sp_copy(A); + if (T->m != n || T->n != m) + T = sp_resize(T, n, m); + + for (i=0; irow[i].len = 0; + T->flag_col = 0; + T->flag_diag = 0; + + for (i=0; irow + i; + slen = srow->len; + selt = srow->elt; + for (j_idx = 0; j_idx < slen; j_idx++, selt++) { + drow = T->row + selt->col; + dlen = drow->len; + if (dlen == drow->maxlen) { + // drow = sprow_xpd(drow, (3*dlen)/2, TYPE_SPMAT); + drow = sprow_xpd(drow, dlen+10, TYPE_SPMAT); + drow->len = dlen; + } + delt = drow->elt + dlen; + delt->val = selt->val; + delt->col = i; + drow->len ++; + } + } + + return T; +} + diff --git a/hqp/meschext_ea.h b/hqp/meschext_ea.h new file mode 100644 index 0000000..3173613 --- /dev/null +++ b/hqp/meschext_ea.h @@ -0,0 +1,215 @@ +/* + * meschext_ea.h + * - some Meschach add-ons and extensions + * + * E. Arnold 03/07/97 + * + */ + +/* + Copyright (C) 1997--1998 Eckhard Arnold + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef MESCHEXT_EA_H +#define MESCHEXT_EA_H + +extern "C" { +#include +#include +} + +/* Entry level access to data structures */ +/* Redefine some macros from matrix.h with typecast (int) */ +/* Define access macros for integer vectors */ +#ifdef DEBUG +/* returns x[i] */ +#undef v_entry +#define v_entry(x,i) (((int) (i) < 0 || (int) (i) >= (int) (x)->dim) ? \ + error(E_BOUNDS,"v_entry"), 0.0 : (x)->ve[i] ) + +/* x[i] <- val */ +#undef v_set_val +#define v_set_val(x,i,val) ((x)->ve[i] = ((int) (i) < 0 || \ + (int) (i) >= (int) (x)->dim) ? \ + error(E_BOUNDS,"v_set_val"), 0.0 : (val)) + +/* x[i] <- x[i] + val */ +#undef v_add_val +#define v_add_val(x,i,val) ((x)->ve[i] += ((int) (i) < 0 || \ + (int) (i) >= (int) (x)->dim) ? \ + error(E_BOUNDS,"v_add_val"), 0.0 : (val)) + +/* x[i] <- x[i] - val */ +#undef v_sub_val +#define v_sub_val(x,i,val) ((x)->ve[i] -= ((int) (i) < 0 || \ + (int) (i) >= (int) (x)->dim) ? \ + error(E_BOUNDS,"v_sub_val"), 0.0 : (val)) + +/* returns A[i][j] */ +#undef m_entry +#define m_entry(A,i,j) (((int) (i) < 0 || (int) (i) >= (int) (A)->m || \ + (int) (j) < 0 || (int) (j) >= (int) (A)->n) ? \ + error(E_BOUNDS,"m_entry"), 0.0 : (A)->me[i][j] ) + +/* A[i][j] <- val */ +#undef m_set_val +#define m_set_val(A,i,j,val) ((A)->me[i][j] = ((int) (i) < 0 || \ + (int) (i) >= (int) (A)->m || \ + (int) (j) < 0 || \ + (int) (j) >= (int) (A)->n) ? \ + error(E_BOUNDS,"m_set_val"), 0.0 : (val) ) + +/* A[i][j] <- A[i][j] + val */ +#undef m_add_val +#define m_add_val(A,i,j,val) ((A)->me[i][j] += ((int) (i) < 0 || \ + (int) (i) >= (int) (A)->m || \ + (int) (j) < 0 || \ + (int) (j) >= (int) (A)->n) ? \ + error(E_BOUNDS,"m_add_val"), 0.0 : (val) ) + +/* A[i][j] <- A[i][j] - val */ +#undef m_sub_val +#define m_sub_val(A,i,j,val) ((A)->me[i][j] -= ((int) (i) < 0 || \ + (int) (i) >= (int) (A)->m || \ + (int) (j) < 0 || \ + (int) (j) >= (int) (A)->n) ? \ + error(E_BOUNDS,"m_sub_val"), 0.0 : (val) ) + +/* returns x[i] */ +#define iv_entry(x,i) (((int) (i) < 0 || (int) (i) >= (int) (x)->dim) ? \ + error(E_BOUNDS,"iv_entry"), 0 : (x)->ive[i] ) + +/* x[i] <- val */ +#define iv_set_val(x,i,val) ((x)->ive[i] = ((int) (i) < 0 || \ + (int) (i) >= (int) (x)->dim) ? \ + error(E_BOUNDS,"iv_set_val"), 0 : (val)) + +/* x[i] <- x[i] + val */ +#define iv_add_val(x,i,val) ((x)->ive[i] += ((int) (i) < 0 || \ + (int) (i) >= (int) (x)->dim) ? \ + error(E_BOUNDS,"iv_add_val"), 0 : (val)) + +/* x[i] <- x[i] - val */ +#define iv_sub_val(x,i,val) ((x)->ive[i] -= ((int) (i) < 0 || \ + (int) (i) >= (int) (x)->dim) ? \ + error(E_BOUNDS,"iv_sub_val"), 0 : (val)) + +#else + +/* returns x[i] */ +#define iv_entry(x,i) ((x)->ive[i]) + +/* x[i] <- val */ +#define iv_set_val(x,i,val) ((x)->ive[i] = (val)) + +/* x[i] <- x[i] + val */ +#define iv_add_val(x,i,val) ((x)->ive[i] += (val)) + + /* x[i] <- x[i] - val */ +#define iv_sub_val(x,i,val) ((x)->ive[i] -= (val)) + +#endif + +//---------- Meschach extensions ---------- + +// Prints internal parameters of MAT * data structure. +extern void m_output_g(MAT *A); + +// Prints internal parameters of VEC * data structure. +extern void v_output_g(const VEC *A); + +// m_copy1 -- copies matrix into new area, resizes out to correct size. +extern MAT *m_copy1(const MAT *in, MAT *out); + +// v_copy1 -- copies vector into new area, resizes out to correct size. +extern VEC *v_copy1(const VEC *in, VEC *out); + +// v_diag -- get diagonal entries of a matrix +extern VEC *v_diag(MAT *A, VEC *C); + +// dm_mlt -- diagonal matrix matrix multiplication +extern MAT *dm_mlt(MAT *A, VEC *B, MAT *C); + +// md_mlt -- matrix diagonal matrix multiplication +extern MAT *md_mlt(MAT *A, VEC *B, MAT *C); + +// m_symm -- make square matrix symmetric, +extern MAT *m_symm(const MAT *in, MAT *out); + +// rel_symm -- check square matrix for symmetry. +extern double rel_symm(const MAT *in); + +// CHsolve with matrix right hand side. +extern MAT *CHsolveM(MAT *A, MAT *B, MAT *C); + +// CHsolve with transposed matrix right hand side. +extern MAT *CHsolveMT(MAT *A, MAT *B, MAT *C); + +// BKPsolve with matrix right hand side. +extern MAT *BKPsolveM(MAT *A, PERM *pivot, PERM *blocks, MAT *B, MAT *C); + +// BKPsolve with transposed matrix right hand side. +extern MAT *BKPsolveMT(MAT *A, PERM *pivot, PERM *blocks, MAT *B, MAT *C); + +// LUsolve with matrix right hand side. +extern MAT *LUsolveM(MAT *A, PERM *pivot, MAT *B, MAT *C); + +// LUsolve with transposed matrix right hand side. +extern MAT *LUsolveMT(MAT *A, PERM *pivot, MAT *B, MAT *C); + +// GE_QP -- Generalized elimination for quadratic programming +extern void GE_QP(MAT *A, MAT *S, MAT *Z, MAT *PQ, double eps); + +// Matrix concatenation by rows C = [A; B]. +extern MAT *m_concatc(MAT *A, MAT *B, MAT *C); + +// Vector concatenation C = [A; B] +extern VEC *v_concat(VEC *A, VEC *B, VEC *C); + +// C(i) = A(iv(i)) +extern VEC *v_move_iv(const VEC *A, const IVEC *iv, VEC *C); + +// C(iv(i)) = A(i) +extern VEC *v_set_iv(VEC *A, IVEC *iv, VEC *C); + +// Euclidean norm of a SPROW. +extern Real sprow_norm2(const SPROW *r); + +// Copy a block from sparse matrix src to dense matrix dst +extern void sp_extract_mat_iv(const SPMAT *src, const IVEC *iv, int j_offs, + MAT *dst); + +// Block from sparse matrix - dense matrix multiplication +extern MAT *bspm_mlt(const SPMAT *A, int i0, int j0, int m0, + const MAT *B, MAT *C); + +// Dense matrix - block from transposed sparse matrix multiplication +extern MAT *mbsptr_mlt(const MAT *B, const SPMAT *A, int i0, int j0, int n0, + MAT *C); + +// Block from sparse matrix - vector multiplication. +extern VEC *bspv_mlt(const SPMAT *A, int i0, int j0, int m0, const VEC *B, + VEC *C) ; + +// Check column indices of a sparse matrix +extern void check_sparse(SPMAT *C); + +// Transpose of a sparse matrix +extern SPMAT *sp_transp_ea(const SPMAT *A, SPMAT *T); + +#endif diff --git a/hqp/meschext_hl.C b/hqp/meschext_hl.C new file mode 100644 index 0000000..70a96f6 --- /dev/null +++ b/hqp/meschext_hl.C @@ -0,0 +1,1325 @@ +/* + * meschext_hl.C + * -- some Meschach add-ons and extensions + */ + +/* + Copyright (C) 1996--1998 Hartmut Linke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include "Meschach.h" + + +#define MINROWLEN 10 +#define INSERT_IDX(idx) (-(idx + 2)) +#define MEM_MOVE(src,dst,len) MEM_COPY(src,dst,len) +#define SPROW_IDX(r,k) \ + ((k < r->elt[0].col) ? -2 : \ + ((k > r->elt[r->len-1].col) ? -(r->len+2) : sprow_idx(r,k))) + +/* + sprow_ins_val (Copyright Ruediger Franke) + -- insert the idx's entry into sparse row r with col j + -- derived frome sprow_set_val (Copyright D.E. Steward, Z. Leyk) +*/ + +static Real sprow_ins_val(SPROW *r, int idx, Real val, int j, int type) +{ + int new_len; + + if (!r) + error(E_NULL,"sprow_ins_val"); + + /* shift & insert new value */ + if (idx < 0) + idx = INSERT_IDX(idx); + if ( r->len >= r->maxlen ) { + r->len = r->maxlen; + new_len = max(2*r->maxlen+1,5); + if (mem_info_is_on()) { + mem_bytes(type, r->maxlen*sizeof(row_elt), + new_len*sizeof(row_elt)); + } + + r->elt = RENEW(r->elt,new_len,row_elt); + if ( ! r->elt ) /* can't allocate */ + error(E_MEM,"sprow_ins_val"); + r->maxlen = new_len; + } + + if ( idx < r->len ) + MEM_MOVE((char *)(&(r->elt[idx])),(char *)(&(r->elt[idx+1])), + (r->len-idx)*sizeof(row_elt)); + + r->len++; + r->elt[idx].col = j; + + return r->elt[idx].val = val; +} + +/* + * derived from sprow_inprod (Copyright Ruediger Franke) + */ +Real sprow_inprod_full(const SPROW *r1, const SPROW *r2) +{ + Real sum; + int j_idx1, j_idx2, j1, j2; + int len1, len2; + row_elt *elt1, *elt2; + + j_idx1=0; + j_idx2=0; + len1 = r1->len; + len2 = r2->len; + elt1 = r1->elt; + elt2 = r2->elt; + j1 = elt1->col; + j2 = elt2->col; + sum = 0.0; + while (j_idx1 < len1 && j_idx2 < len2) { + if (j1 < j2) { + j_idx1 ++; + elt1 ++; + j1 = elt1->col; + } + else if (j1 > j2) { + j_idx2 ++; + elt2 ++; + j2 = elt2->col; + } + else { + sum += elt1->val * elt2->val; + + j_idx1 ++; + elt1 ++; + j1 = elt1->col; + + j_idx2 ++; + elt2 ++; + j2 = elt2->col; + } + } + + return sum; +} + +/* sprow_cpy -- copies r1 into r_out + -- cannot be done in-situ + -- type must be SPMAT or SPROW depending on + whether r_out is a row of a SPMAT structure + or a SPROW variable + -- returns r_out */ + +SPROW *sprow_cpy(const SPROW *r1, SPROW *r_out, int type) +{ + int len1, len_out; + + if ( ! r1 ) + error(E_NULL,"sprow_cpy"); + if ( ! r_out ) + error(E_NULL,"sprow_cpy"); + if ( r1 == r_out ) + error(E_INSITU,"sprow_cpy"); + + /* Initialise */ + len1 = r1->len; + len_out = r_out->maxlen; + + if(len1 > len_out) { + + if (mem_info_is_on()) { + mem_bytes(type, len_out*sizeof(row_elt), + len1*sizeof(row_elt)); + } + + r_out->elt = RENEW(r_out->elt,len1,row_elt); + if ( ! r_out->elt ) /* can't allocate */ + error(E_MEM,"sprow_cpy"); + r_out->maxlen = len1; + + }; + + MEM_COPY((char *)(r1->elt),(char *)(r_out->elt), + len1*sizeof(row_elt)); + + r_out->len = len1; + + return r_out; +} + + +/* + derived from sprow_smlt (Copyright D.E. Steward, Z. Leyk) + sprow_smlt_full -- sets r_out <- alpha*r1 + -- can be in situ + -- returns r_out +*/ + +SPROW *sprow_smlt_full(SPROW *r1, double alpha, SPROW *r_out, int type) +{ + int i, len; + row_elt *elt, *elt_out; + + if ( ! r1 ) + error(E_NULL,"sprow_smlt r1"); + if ( ! r_out ) + error(E_NULL,"sprow_smlt r_out"); + + /* Initialise */ + len = r1->len; + elt = r1->elt; + + r_out = sprow_resize(r_out,len,type); + elt_out = r_out->elt; + + for ( i = 0 ; i < len; elt++,elt_out++,i++) + elt_out->val = alpha*elt->val; + + return r_out; +} + + +/* + derived from sprow_mltadd (Copyright D.E. Steward, Z. Leyk) + -- sets r_out <- r1 + alpha.r2 + -- cannot be in situ + -- type must be SPMAT or SPROW depending on + whether r_out is a row of a SPMAT structure + or a SPROW variable + -- returns r_out +*/ +SPROW *sprow_mltadd_full(SPROW *r1, SPROW *r2, double alpha, + SPROW *r_out, int type) +{ + int idx1, idx2, idx_out, len1, len2, len_out; + row_elt *elt1, *elt2, *elt_out; + + if ( ! r1 || ! r2 ) + error(E_NULL,"sprow_mltadd"); + if ( r1 == r_out || r2 == r_out ) + error(E_INSITU,"sprow_mltadd"); + if ( ! r_out ) + error(E_NULL,"sprow_mltadd"); + + /* Initialise */ + len1 = r1->len; + len2 = r2->len; + len_out = r_out->maxlen; + + idx1 = 0; + idx2 = 0; + idx_out = 0; + + /* idx1 = idx2 = idx_out = 0; */ + elt1 = r1->elt; + elt2 = r2->elt; + elt_out = r_out->elt; + + while ( idx1 < len1 || idx2 < len2 ) + { + if ( idx_out >= len_out ) + { /* r_out is too small */ + r_out->len = idx_out; + r_out = sprow_xpd(r_out,0,type); + len_out = r_out->maxlen; + elt_out = &(r_out->elt[idx_out]); + } + if ( idx2 >= len2 || (idx1 < len1 && elt1->col <= elt2->col) ) + { + elt_out->col = elt1->col; + elt_out->val = elt1->val; + if ( idx2 < len2 && elt1->col == elt2->col ) + { + elt_out->val += alpha*elt2->val; + elt2++; idx2++; + } + elt1++; idx1++; + } + else + { + elt_out->col = elt2->col; + elt_out->val = alpha*elt2->val; + elt2++; idx2++; + } + elt_out++; idx_out++; + } + + r_out->len = idx_out; + + return r_out; +} + +/* + derived from sprow_smlt (Copyright D.E. Steward, Z. Leyk) + sprow_smlt_full -- sets r1 <- alpha*r1 from idx to row->len + -- in situ +*/ +SPROW *sprow_smlt_idx(SPROW *r1, int idx, double alpha) +{ + int len; + row_elt *elt; + + if ( ! r1 ) + error(E_NULL,"sprow_smlt"); + + len = r1->len; + elt = r1->elt + idx; + for ( ; idx < len; elt++,idx++) + elt->val *= alpha; + + return r1; +} + +/* spbkp_mltadd -- sets r_out <- r1 + alpha.r2 (Copyright Ruediger Franke) + * -- derived frome sprow_mltadd (Copyright D.E. Steward, Z. Leyk) + * -- specialized for BKP: + * + r1 starts with index r1->diag + * + start index for r2 is passed as argument (r2_idx0) + * + r_out is filled from index 0; r_out->diag is set + * -- cannot be in situ + * -- type must be SPMAT or SPROW depending on + * whether r_out is a row of a SPMAT structure + * or a SPROW variable + * -- returns r_out + */ +static SPROW *spbkp_mltadd(const SPROW *r1, const SPROW *r2, int r2_idx0, + Real s, SPROW *r_out, int type) +{ + int idx1, idx2, idx_out, len1, len2, len_out; + row_elt *elt1, *elt2, *elt_out; + + if (!r1 || !r2) + error(E_NULL,"spbkp_mltadd"); + if (r1 == r_out || r2 == r_out) + error(E_INSITU,"spbkp_mltadd"); + if (!r_out) + /* don't use sprow_get() because of Meschach memory management */ + /* r_out = sprow_get(MINROWLEN); */ + error(E_NULL,"spbkp_mltadd"); + + /* Initialise */ + len1 = r1->len; + len2 = r2->len; + len_out = r_out->maxlen; + idx1 = r1->diag; + idx2 = r2_idx0; + idx_out = 0; + if (idx1 >= 0 || idx2 >= 0) + r_out->diag = 0; + else + r_out->diag = -2; + idx1 = (idx1 < 0)? INSERT_IDX(idx1): idx1; + idx2 = (idx2 < 0)? INSERT_IDX(idx2): idx2; + elt1 = &(r1->elt[idx1]); + elt2 = &(r2->elt[idx2]); + elt_out = &(r_out->elt[idx_out]); + + while (idx1 < len1 || idx2 < len2) { + if (idx_out >= len_out) { + /* r_out is too small */ + r_out->len = idx_out; + r_out = sprow_xpd(r_out,0,type); + len_out = r_out->maxlen; + elt_out = &(r_out->elt[idx_out]); + } + if (idx2 >= len2 || (idx1 < len1 && elt1->col <= elt2->col)) { + elt_out->col = elt1->col; + elt_out->val = elt1->val; + if (idx2 < len2 && elt1->col == elt2->col) { + elt_out->val += s*elt2->val; + elt2++; + idx2++; + } + elt1++; + idx1++; + } + else { + elt_out->col = elt2->col; + elt_out->val = s*elt2->val; + elt2++; + idx2++; + } + elt_out++; + idx_out++; + } + r_out->len = idx_out; + + return r_out; +} + + +/* + derived from sprow_ip (Copyright D.E. Steward, Z. Leyk) + -- finds the (partial) inner product of a pair of sparse rows + -- uses a "merging" approach & assumes column ordered rows + -- row indices for inner product are all < lim +*/ + +double sprow_ip(SPROW *row1, SPROW *row2, int lim) +{ + int idx1, idx2, len1, len2, tmp; + row_elt *elts1, *elts2; + Real sum; + + elts1 = row1->elt; elts2 = row2->elt; + len1 = row1->len; len2 = row2->len; + + sum = 0.0; + + if ( len1 <= 0 || len2 <= 0 ) + return 0.0; + if ( elts1->col >= lim || elts2->col >= lim ) + return 0.0; + + /* use sprow_idx() to speed up inner product where one row is + much longer than the other */ + idx1 = idx2 = 0; + if ( len1 > 2*len2 ) + { + idx1 = SPROW_IDX(row1,elts2->col); + idx1 = (idx1 < 0) ? -(idx1+2) : idx1; + if ( idx1 < 0 ) + error(E_UNKNOWN,"sprow_ip"); + len1 -= idx1; + } + else if ( len2 > 2*len1 ) + { + idx2 = SPROW_IDX(row2,elts1->col); + idx2 = (idx2 < 0) ? -(idx2+2) : idx2; + if ( idx2 < 0 ) + error(E_UNKNOWN,"sprow_ip"); + len2 -= idx2; + } + if ( len1 <= 0 || len2 <= 0 ) + return 0.0; + + elts1 = &(elts1[idx1]); elts2 = &(elts2[idx2]); + + + for ( ; ; ) /* forever do... */ + { + if ( (tmp=elts1->col-elts2->col) < 0 ) + { + len1--; elts1++; + if ( ! len1 || elts1->col >= lim ) + break; + } + else if ( tmp > 0 ) + { + len2--; elts2++; + if ( ! len2 || elts2->col >= lim ) + break; + } + else + { + sum += elts1->val * elts2->val; + len1--; elts1++; + len2--; elts2++; + if ( ! len1 || ! len2 || + elts1->col >= lim || elts2->col >= lim ) + break; + } + } + + return sum; +} + +double sprow_sqr_full(SPROW *row) +{ + row_elt *elts; + int idx, len; + Real sum, tmp; + + sum = 0.0; + elts = row->elt; len = row->len; + for ( idx = 0; idx < len; idx++, elts++ ) + { + tmp = elts->val; + sum += tmp*tmp; + } + + return sum; +} + + +/* sp_mmt_mlt -- compute A.A^T where A is a given sparse matrix */ +SPMAT *sp_mmt_mlt(const SPMAT *A, SPMAT *AAT) +{ + + int i, i_min, i_max, j, j_min, j_max, m, hlen, vlen, + rlen_aat, clen_aat; + Real tmp; + SPROW *hrow, *vrow, *c_aat, *r_aat; + row_elt *helt, *velt, *celt_aat, *relt_aat; + + + if ( ! A ) + error(E_NULL,"sp_AAT"); + if ( ! AAT ) + error(E_NULL,"sp_AAT"); + + if(AAT->m != A->m || AAT->n != A->m) + error(E_SIZES,"sp_AAT"); + + for (i = 0; i < AAT->m; i++) + AAT->row[i].len = 0; + + m = A->m; + + for( i = 0; i < m; i++) { + + hrow = A->row + i; + hlen = hrow->len; + helt = hrow->elt; + i_min = helt[0].col; + i_max = helt[hlen-1].col; + + r_aat = AAT->row + i; + rlen_aat = r_aat->len; + + if (rlen_aat == r_aat->maxlen) + r_aat = sprow_xpd(r_aat,r_aat->maxlen+10,TYPE_SPMAT); + + relt_aat = r_aat->elt + rlen_aat; + relt_aat->val = sprow_sqr_full(hrow); + relt_aat->col = i; + rlen_aat++; + + for(j = i+1; j < m; j++) { + + vrow = A->row+j; + vlen = vrow->len; + velt = vrow->elt; + j_min = velt[0].col; + j_max = velt[vlen-1].col; + + if((i_min <= j_max) || (j_min <= i_max)) { + + tmp = sprow_inprod_full(hrow,vrow); + + if(tmp != 0) { + + if (rlen_aat == r_aat->maxlen) + r_aat = sprow_xpd(r_aat,r_aat->maxlen+10,TYPE_SPMAT); + + relt_aat = r_aat->elt + rlen_aat; + relt_aat->val = tmp; + relt_aat->col = j; + rlen_aat++; + + c_aat = AAT->row + j; + clen_aat = c_aat->len; + + if (clen_aat == c_aat->maxlen) + c_aat = sprow_xpd(c_aat,c_aat->maxlen+10,TYPE_SPMAT); + + celt_aat = c_aat->elt + clen_aat; + celt_aat->val = tmp; + celt_aat->col = i; + c_aat->len = clen_aat + 1;; + + }; + + }; + + }; + + r_aat->len = rlen_aat; + + }; + + return AAT; + +} + +/* + sp_mmt2_mlt -- compute A.A^T where A is a given sparse matrix +*/ +SPMAT *sp_mmt2_mlt(const SPMAT *A,const SPMAT *AT, SPMAT *AAT) +{ + + int i, idx, j, len, m; + Real s; + SPMAT *swap_mat; + SPROW *row, *swap, tmp_row; + row_elt *elt; + + + if ( ! A || !AT || !AAT) + error(E_NULL,"sp_AAT"); + + if(AAT->m != A->m || AAT->n != A->m) + error(E_SIZES,"sp_AAT"); + + if(AAT->m != AT->n || AAT->n != AT->n) + error(E_SIZES,"sp_AAT"); + + for (i = 0; i < AAT->m; i++) + AAT->row[i].len = 0; + + AAT->flag_diag = 0; + AAT->flag_col = 0; + + m = A->m; + swap_mat = sp_get(1,m,MINROWLEN); + swap = swap_mat->row; + + for( i = 0; i < m; i++) { + + row = A->row + i; + elt = row->elt; + len = row->len; + idx = 0; + + for(; idx < len; idx++, elt++) { + + j = elt->col; + s = elt->val; + + sprow_mltadd_full(AAT->row+i,AT->row+j,s,swap,TYPE_SPMAT); + + /* exchange swap with row #j */ + MEM_COPY(AAT->row+i, &tmp_row, sizeof(SPROW)); + MEM_COPY(swap, AAT->row+i, sizeof(SPROW)); + MEM_COPY(&tmp_row, swap, sizeof(SPROW)); + + }; + + }; + + sp_free(swap_mat); + + return AAT; + +} + +/* + sp_mmt_mlt_u -- compute A.A^T where A is a given sparse matrix + only the upper part of AAT is filled +*/ +SPMAT *sp_mmt2_mlt_u(const SPMAT *A,const SPMAT *AT, SPMAT *AAT) +{ + + int i, idx, idx1, j, len, m; + Real s; + SPMAT *swap_mat; + SPROW *row, *row1, *swap, tmp_row; + row_elt *elt; + + + if ( ! A || !AT || !AAT) + error(E_NULL,"sp_AAT"); + + if(AAT->m != A->m || AAT->n != A->m) + error(E_SIZES,"sp_AAT"); + + if(AAT->m != AT->n || AAT->n != AT->n) + error(E_SIZES,"sp_AAT"); + + for (i = 0; i < AAT->m; i++) { + AAT->row[i].len = 0; + AAT->row[i].diag = 0; + } + + AAT->flag_diag = 0; + AAT->flag_col = 0; + + m = A->m; + swap_mat = sp_get(1,m,MINROWLEN); + swap = swap_mat->row; + + for( i = 0; i < m; i++) { + + row = A->row + i; + elt = row->elt; + len = row->len; + idx = 0; + + for(; idx < len; idx++, elt++) { + + j = elt->col; + s = elt->val; + row1 = AT->row+j; + idx1 = SPROW_IDX(row1,i); + if(idx1 < 0) idx1 = INSERT_IDX(idx1); + if(idx1 > 0) idx1--; + + spbkp_mltadd(AAT->row+i,row1,0,s,swap,TYPE_SPMAT); + + /* exchange swap with row #j */ + MEM_COPY(AAT->row+i, &tmp_row, sizeof(SPROW)); + MEM_COPY(swap, AAT->row+i, sizeof(SPROW)); + MEM_COPY(&tmp_row, swap, sizeof(SPROW)); + + }; + + }; + + sp_free(swap_mat); + + return AAT; + +} + + +/* spLMsolve + -- solve L.OUT=B where L is a sparse lower triangular matrix, + -- OUT,B are sparse matrices + -- returns OUT; operation may not be in-situ + if L is not blocktriangular, OUT may be full !!! + +*/ +SPMAT *spLMsolve(SPMAT *L, const SPMAT *B,SPMAT *OUT) +{ + + int i, j_idx, in_situ, n; + SPMAT *tmp_mat; + SPROW *row, *tmp1_row, *tmp; + row_elt *elt; + + + if ( L == SMNULL || B == SMNULL ) + error(E_NULL,"spLsolve"); + if ( L->m != L->n ) + error(E_SQUARE,"spLsolve"); + if ( B->m != L->m ) + error(E_SIZES,"spLsolve"); + // if ( ! L->flag_diag ) + sp_diag_access(L); + if( !OUT) + OUT = sp_get(B->m,B->n,MINROWLEN); + if( OUT->m != B->m || OUT->n != B->n) + sp_resize(OUT,B->m,B->n); + if(B == OUT) + in_situ = 1; + else + in_situ = 0; + + + tmp_mat = sp_get(1,B->n,MINROWLEN); + tmp = tmp_mat->row; + + n = L->n; + + for ( i = 0; i < n; i++ ) { + + row = &(L->row[i]); + elt = row->elt; + + if(!in_situ) + sprow_cpy(B->row+i,OUT->row+i,TYPE_SPMAT); + + for ( j_idx = 0; j_idx < row->len; j_idx++, elt++ ) { + if ( elt->col >= i ) + break; + + tmp1_row = &(OUT->row[elt->col]); + sprow_mltadd_full(OUT->row+i,tmp1_row,-elt->val,tmp,TYPE_SPMAT); + sprow_cpy(tmp,OUT->row+i,TYPE_SPMAT); + } + if ( row->diag >= 0 ) { + sprow_smlt_full(OUT->row+i,1.0/row->elt[row->diag].val, + OUT->row+i,TYPE_SPMAT); + } + else + error(E_SING,"spLMsolve"); + }; + + sp_free(tmp_mat); + + return OUT; +} + + +/* spLDLTsolve -- solve L.D.L^T.out=b where L is a sparse matrix, + -- out, b dense vectors + -- returns out; operation may be in-situ */ +VEC *spLDLTsolve(SPMAT *L,const VEC *b,VEC *out) +{ + int col, i, j, j_idx, max_col, n; + SPROW *row; + row_elt *elt; + Real diag_val, sum, *out_ve; + + if ( L == SMNULL || b == VNULL ) + error(E_NULL,"spCHsolve"); + if ( L->m != L->n ) + error(E_SQUARE,"spCHsolve"); + if ((int)b->dim != L->m ) + error(E_SIZES,"spCHsolve"); + + if ( ! L->flag_diag ) + sp_diag_access(L); + + col = 0; + + out = v_copy(b,out); + out_ve = out->ve; + + /* forward substitution: solve L.x=b for x */ + n = L->n; + + for ( i = 0; i < n; i++ ) { + sum = out_ve[i]; + row = &(L->row[i]); + elt = row->elt; + + for ( j_idx = 0; j_idx < row->len; j_idx++, elt++ ) { + if ( elt->col >= i ) + break; + sum -= elt->val*out_ve[elt->col]; + } + + out_ve[i] = sum; + if ( row->diag < 0 ) error(E_SING,"spLDLTsolve"); + + }; + + + /* backward substitution: solve L^T.out = D^1.x for out */ + for ( i = n-1; i >= 0; i-- ) { + + row = &(L->row[i]); + /* Note that row->diag >= 0 by above loop */ + + elt = row->elt; + max_col = elt[row->len-1].col + 1; + if(max_col > col) col = max_col; + + elt = &(row->elt[row->diag]); + diag_val = elt->val; + sum = out_ve[i]/diag_val; + + for(j = i+1; j < col; j++) { + + /* scan down column */ + row = &(L->row[j]); + j_idx = SPROW_IDX(row,i); + if(j_idx >= 0) { + elt = &(row->elt[j_idx]); + sum -= elt->val*out_ve[j]; + }; + + }; + + out_ve[i] = sum; + + }; + + return out; +} + +SPMAT *spCHOLfac(SPMAT *A) +/* + * -- factorize A in situ into A = LL' + */ +{ + int i, j, n; + int idx, len; + Real aii; + Real s; + SPMAT *swap_mat; + SPROW *row, *swap, tmp_row; + row_elt *elt; + + if (!A ) + error(E_NULL, "spCHOLfac"); + if (A->n != A->m) + error(E_SIZES, "spCHOLfac"); + + n = A->n; + + /* don't use sprow_get because of Meschach memory management */ + /* swap = sprow_get(MINROWLEN); */ + swap_mat = sp_get(1, n, MINROWLEN); + swap = swap_mat->row; + + if (!A->flag_diag) + sp_diag_access(A); + A->flag_col = 0; + + for (i = 0; i < n-1; i++) { + + row = A->row + i; + idx = row->diag; + + if (idx >= 0) { + aii = row->elt[idx].val; + if( aii > 0.0 ) + aii = row->elt[idx].val = sqrt(aii); + else + error(E_POSDEF,"spCHfactor"); + idx ++; + } + else + error(E_POSDEF,"spCHfactor"); + + sprow_smlt_idx(row,idx,1.0/aii); + + elt = row->elt + idx; + len = row->len; + for (; idx < len; idx++, elt++) { + j = elt->col; + s = elt->val; + if (s != 0.0) { + spbkp_mltadd(A->row+j, row, idx, -s, swap, TYPE_SPMAT); + /* exchange swap with row #j */ + MEM_COPY(A->row+j, &tmp_row, sizeof(SPROW)); + MEM_COPY(swap, A->row+j, sizeof(SPROW)); + MEM_COPY(&tmp_row, swap, sizeof(SPROW)); + } + } + } + + if (n > 0) { + row = A->row + n-1; + idx = row->diag; + + if (idx >= 0) { + aii = row->elt[idx].val; + if( aii > 0.0 ) + row->elt[idx].val = sqrt(aii); + else + error(E_POSDEF,"spCHfactor"); + } + else + error(E_POSDEF,"spCHfactor"); + } + + /* sprow_free(swap); */ + sp_free(swap_mat); + + A->flag_diag = 1; + + return A; +} + + +SPMAT *spMODCHOLfac(SPMAT *A,VEC *b,double eps) +/* + * -- factorize A in situ into A = LL' + */ +{ + int i, j, n; + int idx, len; + Real aii; + Real s; + SPMAT *swap_mat; + SPROW *row, *swap, tmp_row; + row_elt *elt; + + if (!A ) + error(E_NULL, "spMODCHOLfac"); + if (A->n != A->m) + error(E_SIZES, "spMODCHOLfac"); + if ((int)A->n != (int)b->dim) + error(E_SIZES, "spMODCHOLfac"); + + n = A->n; + + /* don't use sprow_get because of Meschach memory management */ + /* swap = sprow_get(MINROWLEN); */ + swap_mat = sp_get(1, n, MINROWLEN); + swap = swap_mat->row; + + if (!A->flag_diag) + sp_diag_access(A); + A->flag_col = 0; + + for (i = 0; i < n-1; i++) { + + row = A->row + i; + idx = row->diag; + + if (idx >= 0) { + aii = row->elt[idx].val; + if( aii > eps ) { + aii = row->elt[idx].val = sqrt(aii); + idx ++; + sprow_smlt_idx(row,idx,1.0/aii); + + elt = row->elt + idx; + len = row->len; + for (; idx < len; idx++, elt++) { + j = elt->col; + s = elt->val; + if (s != 0.0) { + spbkp_mltadd(A->row+j, row, idx, -s, swap, TYPE_SPMAT); + /* exchange swap with row #j */ + MEM_COPY(A->row+j, &tmp_row, sizeof(SPROW)); + MEM_COPY(swap, A->row+j, sizeof(SPROW)); + MEM_COPY(&tmp_row, swap, sizeof(SPROW)); + }; + }; + } + else { + row->elt[idx].val = 1.0; + idx ++; + sprow_smlt_idx(row,idx,0.0); + b->ve[i] = 0.0; + }; + } + else { + sprow_ins_val(row,idx,1.0,i,TYPE_SPMAT); + idx ++; + sprow_smlt_idx(row,idx,0.0); + b->ve[i] = 0.0; + }; + } + + if (n > 0) { + row = A->row + n-1; + idx = row->diag; + + if (idx >= 0) { + aii = row->elt[idx].val; + if( aii > eps ) + row->elt[idx].val = sqrt(aii); + else { + row->elt[idx].val = 1.0; + b->ve[n-1] = 0.0; + }; + } + else { + sprow_ins_val(row,idx,1.0,n-1,TYPE_SPMAT); + b->ve[n-1] = 0.0; + }; + } + + /* sprow_free(swap); */ + sp_free(swap_mat); + + A->flag_diag = 1; + + return A; +} + + +/* + derived from spCHsolve (Copyright D.E. Steward, Z. Leyk) + -- solve L.L^T.out=b where L is a sparse matrix, + -- out, b dense vectors + -- returns out; operation may be in-situ +*/ +VEC *spCHOLsol(SPMAT *L,VEC *b,VEC *x) +{ + int i, idx, len, n; + SPROW *row; + row_elt *elt; + Real *x_ve, tmp; + + if ( L == SMNULL || b == VNULL ) + error(E_NULL,"spCHsolve"); + if ( L->m != L->n ) + error(E_SQUARE,"spCHsolve"); + if ((int)b->dim != L->m ) + error(E_SIZES,"spCHsolve"); + if ( ! L->flag_diag ) + sp_diag_access(L); + + x = v_copy(b,x); + x_ve = x->ve; + + /* forward substitution: solve L.x=b for x */ + n = L->n; + + for(i = 0; i < n-1; i++) { + + row = L->row + i; + idx = row->diag; + + if(idx >= 0 ) { + + len = row->len; + elt = row->elt + idx; + + if(elt->val > 0.0) { + x_ve[i] /= elt->val; + tmp = x_ve[i]; + idx++; + elt++; + } + else error(E_SING,"forward neg spCHsolve"); + } + else error(E_SING,"forward idx spCHsolve"); + + for(; idx < len; idx++, elt++) + x_ve[elt->col] -= tmp * elt->val; + + }; + + if (n > 0) { + row = L->row + n - 1; + idx = row->diag; + + if(idx >= 0 ) { + + elt = row->elt + idx; + + if(elt->val > 0.0) { + x_ve[n-1] /= elt->val*elt->val; + } + else error(E_SING,"backward neg spCHsolve"); + } + else error(E_SING,"backward idx spCHsolve"); + } + + /* backward substitution: solve L^T.out = x for out */ + for ( i = n-2; i >= 0; i-- ) { + + row = L->row + i; + idx = row->diag; + len = row->len; + elt = row->elt + idx; + tmp = elt->val; + idx++; + elt++; + + for(;idx < len; idx++, elt++) + x_ve[i] -= elt->val*x_ve[elt->col]; + + x_ve[i] = x_ve[i]/tmp; + + }; + + return x; +} + +/* spLMsolve + -- solve L.OUT=B where L is a sparse upper triangular matrix, + -- OUT,B are sparse matrices + -- returns OUT; operation may not be in-situ + if L is not blocktriangular, OUT may be full !!! + +*/ +SPMAT *spLTMsolve(SPMAT *L,SPMAT *B,SPMAT *OUT) +{ + + int i, idx, j, len, n; + Real s; + SPMAT *swap_mat; + SPROW *row, *swap, tmp_row; + row_elt *elt; + + + if ( L == SMNULL || B == SMNULL ) + error(E_NULL,"spLTMsolve"); + if ( L->m != L->n ) + error(E_SQUARE,"spLTMsolve"); + if ( B->m != L->m ) + error(E_SIZES,"spLTMsolve"); + if ( ! L->flag_diag ) + sp_diag_access(L); + if( !OUT) + OUT = sp_get(B->m,B->n,MINROWLEN); + if( OUT->m != B->m || OUT->n != B->n) + sp_resize(OUT,B->m,B->n); + if(B != OUT) + OUT = sp_copy3(B,OUT); + + OUT->flag_diag = 0; + OUT->flag_col = 0; + + n = L->n; + + /* don't use sprow_get because of Meschach memory management */ + /* swap = sprow_get(MINROWLEN); */ + swap_mat = sp_get(1, n, MINROWLEN); + swap = swap_mat->row; + + L->flag_col = 0; + if(!L->flag_diag) + sp_diag_access(L); + + for ( i = 0; i < n; i++ ) { + + row = L->row + i; + idx = row->diag; + + if(idx >= 0 ) { + + len = row->len; + elt = row->elt + idx; + s = elt->val; + + if(s > 0.0) { + sprow_smlt_full(OUT->row+i,1.0/s,OUT->row+i,TYPE_SPMAT); + idx++; + elt++; + } + else error(E_SING,"spLTMsolve"); + } + else error(E_SING,"spLTMsolve"); + + for(; idx < len; idx++, elt++) { + + j = elt->col; + s = elt->val; + + sprow_mltadd_full(OUT->row+j,OUT->row+i,-s,swap,TYPE_SPMAT); + + /* exchange swap with row j */ + MEM_COPY(OUT->row+j, &tmp_row, sizeof(SPROW)); + MEM_COPY(swap, OUT->row+j, sizeof(SPROW)); + MEM_COPY(&tmp_row, swap, sizeof(SPROW)); + } + } + + sp_free(swap_mat); + + return OUT; +} + +/* spmm_mlt -- sparse matrix-matrix multiplication */ +MAT *spmm_mlt(SPMAT *A, MAT *B, MAT *OUT) +{ + + int i, j, m, n, idx, len; + Real **B_v, s; + SPROW *row; + row_elt *elt; + + if ( A==(SPMAT *)NULL || B==(MAT *)NULL ) + error(E_NULL,"spmm_mlt"); + if ((int)A->n != (int)B->m ) + error(E_SIZES,"spmm_mlt"); + if ( B == OUT ) + error(E_INSITU,"spmm_mlt"); + + m = A->m; + n = B->n; + + B_v = B->me; + + if ( OUT==(MAT *)NULL || (int)OUT->m != (int)A->m || + (int)OUT->n != (int)B->n ) + OUT = m_resize(OUT,A->m,B->n); + + m_zero(OUT); + + for (i = 0; i < m; i++) { + + row = A->row + i; + len = row->len; + elt = row->elt; + idx = 0; + + for (; idx < len; idx++, elt++) { + + j = elt->col; + s = elt->val; + + if (s != 0.0) __mltadd__(OUT->me[i],B_v[j],s,n); + + }; + + }; + + return OUT; + +} + + +/* spm_m_spmtr_mlt -- sparse matrix-matrix multiplication */ +MAT *spm_m_spmtr_mlt(SPMAT *A, MAT *B, MAT *OUT) +{ + + int i, j, k, m, n, idx, len; + MAT *mtmp; + VEC *vtmp; + Real **B_me, **mtmp_me,**OUT_me, *vtmp_ve,s; + SPROW *row; + row_elt *elt; + + if ( A==(SPMAT *)NULL || B==(MAT *)NULL ) + error(E_NULL,"m_mlt"); + if ((int)A->n != (int)B->m ) + error(E_SIZES,"m_mlt"); + if ( B == OUT ) + error(E_INSITU,"m_mlt"); + + if ( OUT==(MAT *)NULL || (int)OUT->m != (int)A->m || + (int)OUT->n != (int)A->m ) + OUT = m_resize(OUT,A->m,A->n); + m_zero(OUT); + + mtmp = m_get(A->n,A->m); + vtmp = v_get(A->n); + + m = A->m; + n = B->n; + + B_me = B->me; + mtmp_me = mtmp_me; + vtmp_ve = vtmp_ve; + + for (i = 0; i < m; i++) { + + row = A->row + i; + len = row->len; + elt = row->elt; + idx = 0; + + __zero__(vtmp_ve,n); + + for (; idx < len; idx++, elt++) { + + j = elt->col; + s = elt->val; + + if (s != 0.0) __mltadd__(vtmp_ve,B_me[j],s,n); + + }; + + for(k = 0; k < n; k++) mtmp_me[k][i] = vtmp_ve[k]; + + }; + + vtmp = v_resize(vtmp,m); + vtmp->ve = vtmp->ve; + OUT_me = OUT->me; + + for (i = 0; i < m; i++) { + + row = A->row + i; + len = row->len; + elt = row->elt; + idx = 0; + + __zero__(vtmp_ve,m); + + for (; idx < len; idx++, elt++) { + + j = elt->col; + s = elt->val; + + if (s != 0.0) __mltadd__(vtmp_ve,mtmp_me[j],s,n); + + }; + + for(k = 0; k < m; k++) OUT_me[k][i] = vtmp_ve[k]; + + }; + + M_FREE(mtmp); + V_FREE(vtmp); + + return OUT; + +} diff --git a/hqp/qsort.c b/hqp/qsort.c new file mode 100644 index 0000000..9fcc848 --- /dev/null +++ b/hqp/qsort.c @@ -0,0 +1,182 @@ +/* $NetBSD: qsort.c,v 1.6 1996/12/19 07:56:33 cgd Exp $ */ + +/*- + * Copyright (c) 1992, 1993 + * The Regents of the University of California. All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. All advertising materials mentioning features or use of this software + * must display the following acknowledgement: + * This product includes software developed by the University of + * California, Berkeley and its contributors. + * 4. Neither the name of the University nor the names of its contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +#include + +#if defined(LIBC_SCCS) && !defined(lint) +#if 0 +static char sccsid[] = "from: @(#)qsort.c 8.1 (Berkeley) 6/4/93"; +#else +static char *rcsid = "$NetBSD: qsort.c,v 1.6 1996/12/19 07:56:33 cgd Exp $"; +#endif +#endif /* LIBC_SCCS and not lint */ + +#include +#include + +static __inline char *med3 __P((char *, char *, char *, int (*)())); +static __inline void swapfunc __P((char *, char *, int, int)); + +#define min(a, b) (a) < (b) ? a : b + +/* + * Qsort routine from Bentley & McIlroy's "Engineering a Sort Function". + */ +#define swapcode(TYPE, parmi, parmj, n) { \ + long i = (n) / sizeof (TYPE); \ + register TYPE *pi = (TYPE *) (parmi); \ + register TYPE *pj = (TYPE *) (parmj); \ + do { \ + register TYPE t = *pi; \ + *pi++ = *pj; \ + *pj++ = t; \ + } while (--i > 0); \ +} + +#define SWAPINIT(a, es) swaptype = ((char *)a - (char *)0) % sizeof(long) || \ + es % sizeof(long) ? 2 : es == sizeof(long)? 0 : 1; + +static __inline void +swapfunc(a, b, n, swaptype) + char *a, *b; + int n, swaptype; +{ + if(swaptype <= 1) + swapcode(long, a, b, n) + else + swapcode(char, a, b, n) +} + +#define swap(a, b) \ + if (swaptype == 0) { \ + long t = *(long *)(a); \ + *(long *)(a) = *(long *)(b); \ + *(long *)(b) = t; \ + } else \ + swapfunc(a, b, es, swaptype) + +#define vecswap(a, b, n) if ((n) > 0) swapfunc(a, b, n, swaptype) + +static __inline char * +med3(a, b, c, cmp) + char *a, *b, *c; + int (*cmp)(); +{ + return cmp(a, b) < 0 ? + (cmp(b, c) < 0 ? b : (cmp(a, c) < 0 ? c : a )) + :(cmp(b, c) > 0 ? b : (cmp(a, c) < 0 ? a : c )); +} + +void +qsort(a, n, es, cmp) + void *a; + size_t n, es; + int (*cmp)(); +{ + char *pa, *pb, *pc, *pd, *pl, *pm, *pn; + int d, r, swaptype, swap_cnt; + +loop: SWAPINIT(a, es); + swap_cnt = 0; + if (n < 7) { + for (pm = a + es; pm < (char *) a + n * es; pm += es) + for (pl = pm; pl > (char *) a && cmp(pl - es, pl) > 0; + pl -= es) + swap(pl, pl - es); + return; + } + pm = a + (n / 2) * es; + if (n > 7) { + pl = a; + pn = a + (n - 1) * es; + if (n > 40) { + d = (n / 8) * es; + pl = med3(pl, pl + d, pl + 2 * d, cmp); + pm = med3(pm - d, pm, pm + d, cmp); + pn = med3(pn - 2 * d, pn - d, pn, cmp); + } + pm = med3(pl, pm, pn, cmp); + } + swap(a, pm); + pa = pb = a + es; + + pc = pd = a + (n - 1) * es; + for (;;) { + while (pb <= pc && (r = cmp(pb, a)) <= 0) { + if (r == 0) { + swap_cnt = 1; + swap(pa, pb); + pa += es; + } + pb += es; + } + while (pb <= pc && (r = cmp(pc, a)) >= 0) { + if (r == 0) { + swap_cnt = 1; + swap(pc, pd); + pd -= es; + } + pc -= es; + } + if (pb > pc) + break; + swap(pb, pc); + swap_cnt = 1; + pb += es; + pc -= es; + } + if (swap_cnt == 0) { /* Switch to insertion sort */ + for (pm = a + es; pm < (char *) a + n * es; pm += es) + for (pl = pm; pl > (char *) a && cmp(pl - es, pl) > 0; + pl -= es) + swap(pl, pl - es); + return; + } + + pn = a + n * es; + r = min(pa - (char *)a, pb - pa); + vecswap(a, pb - r, r); + r = min(pd - pc, pn - pd - es); + vecswap(pb, pn - r, r); + if ((r = pb - pa) > es) + qsort(a, r / es, es, cmp); + if ((r = pd - pc) > es) { + /* Iterate rather than recurse to save stack space */ + a = pn - r; + n = r / es; + goto loop; + } +/* qsort(pn - r, r / es, es, cmp);*/ +} diff --git a/hqp/spBKP.C b/hqp/spBKP.C new file mode 100644 index 0000000..ab35959 --- /dev/null +++ b/hqp/spBKP.C @@ -0,0 +1,797 @@ +/* + * BKP factorization for sparse matrices + * - reference: J.R.Bunch, L.Kaufman, and B.N.Parlett: + * Decomposition of a Symmetric Matrix, Numer.Math. 27, 95--109 (1976) + * - factorize sparse matrix A in situ into P'AP = MDM' + * - M is unit lower triangular + * - D is block diagonal with blocks 1x1 and 2x2 + * - delete lower diagonal part, if any (use it for fill-in) + * - P may only be used together with M by BKP-solve routine + * - always update diag-access + * - factor routine performs (i - j) index searches per iteration + * with current row i and pivot row j + * - solve routine needs no index searches at all + * - apply row-header-copy insead of element-copy whenever possible + * + * rf, 9/13/94 + * + * 7/16/95 + * - use SPMAT for swap row for Meschach mem_info compatibility + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#include "Meschach.h" + + +#define MINROWLEN 10 +#define INSERT_IDX(idx) (-(idx + 2)) +#define MEM_MOVE(src,dst,len) MEM_COPY(src,dst,len) + +#if 0 +/* + * memory tests + */ + +static int sprow_size(SPROW *r) +{ + if (!r) + return 0; + + return sizeof(SPROW) + r->maxlen * sizeof(row_elt); +} + +static int spmat_size(SPMAT *m) +{ + if (!m) + return 0; + + int size = sizeof(SPMAT); + int i, i_end = m->max_m; + + for (i=0; irow + i); + + return size; +} +#endif + +/* sprow_ins_val -- insert the idx's entry into sparse row r with col j + * -- derived frome sprow_set_val (Copyright D.E. Steward, Z. Leyk) + */ +static Real sprow_ins_val(SPROW *r, int idx, Real val, int j, int type) +{ + int new_len; + + if (!r) + error(E_NULL,"sprow_ins_val"); + + /* shift & insert new value */ + if (idx < 0) + idx = INSERT_IDX(idx); + if ( r->len >= r->maxlen ) { + r->len = r->maxlen; + new_len = max(2*r->maxlen+1,5); + if (mem_info_is_on()) { + mem_bytes(type, r->maxlen*sizeof(row_elt), + new_len*sizeof(row_elt)); + } + + r->elt = RENEW(r->elt,new_len,row_elt); + if ( ! r->elt ) /* can't allocate */ + error(E_MEM,"sprow_ins_val"); + r->maxlen = new_len; + } + if ( idx < r->len ) + MEM_MOVE((char *)(&(r->elt[idx])),(char *)(&(r->elt[idx+1])), + (r->len-idx)*sizeof(row_elt)); + + r->len++; + r->elt[idx].col = j; + + return r->elt[idx].val = val; +} + +/* spbkp_mltadd -- sets r_out <- r1 + alpha.r2 + * -- derived frome sprow_mltadd (Copyright D.E. Steward, Z. Leyk) + * -- specialized for BKP: + * + r1 starts with index r1->diag + * + start index for r2 is passed as argument (r2_idx0) + * + r_out is filled from index 0; r_out->diag is set + * -- cannot be in situ + * -- type must be SPMAT or SPROW depending on + * whether r_out is a row of a SPMAT structure + * or a SPROW variable + * -- returns r_out + */ +static SPROW *spbkp_mltadd(const SPROW *r1, const SPROW *r2, int r2_idx0, + Real s, SPROW *r_out, int type) +{ + int idx1, idx2, idx_out, len1, len2, len_out; + row_elt *elt1, *elt2, *elt_out; + + if (!r1 || !r2) + error(E_NULL,"spbkp_mltadd"); + if (r1 == r_out || r2 == r_out) + error(E_INSITU,"spbkp_mltadd"); + if (!r_out) + /* don't use sprow_get() because of Meschach memory management */ + /* r_out = sprow_get(MINROWLEN); */ + error(E_NULL,"spbkp_mltadd"); + + /* Initialise */ + len1 = r1->len; + len2 = r2->len; + len_out = r_out->maxlen; + idx1 = r1->diag; + idx2 = r2_idx0; + idx_out = 0; + if (idx1 >= 0 || idx2 >= 0) + r_out->diag = 0; + else + r_out->diag = -2; + idx1 = (idx1 < 0)? INSERT_IDX(idx1): idx1; + idx2 = (idx2 < 0)? INSERT_IDX(idx2): idx2; + elt1 = &(r1->elt[idx1]); + elt2 = &(r2->elt[idx2]); + elt_out = &(r_out->elt[idx_out]); + + while (idx1 < len1 || idx2 < len2) { + if (idx_out >= len_out) { + /* r_out is too small */ + r_out->len = idx_out; + r_out = sprow_xpd(r_out,0,type); + len_out = r_out->maxlen; + elt_out = &(r_out->elt[idx_out]); + } + if (idx2 >= len2 || (idx1 < len1 && elt1->col <= elt2->col)) { + elt_out->col = elt1->col; + elt_out->val = elt1->val; + if (idx2 < len2 && elt1->col == elt2->col) { + elt_out->val += s*elt2->val; + elt2++; + idx2++; + } + elt1++; + idx1++; + } + else { + elt_out->col = elt2->col; + elt_out->val = s*elt2->val; + elt2++; + idx2++; + } + elt_out++; + idx_out++; + } + r_out->len = idx_out; + + return r_out; +} + +/* + * spbkp_mltadd2 -- sets rowj := rowj + s.row + t.row1 + */ +static SPROW *spbkp_mltadd2(SPROW *rowj, const SPROW *row, int idx, Real s, + const SPROW *row1, int idx1, Real t, + SPROW *swap, int type) +{ + spbkp_mltadd(rowj, row, idx, s, swap, type); + spbkp_mltadd(swap, row1, idx1, t, rowj, type); + + return rowj; +} + +static void interchange(SPMAT *A, int i, int j, + const IVEC *col_idxs, SPROW *swap) +/* + * -- interchange row and col j of A and row and col i + * -- i < j + * -- A is the reduced matrix of order n-i+1 + * -- build new row i in swap and exchange headers at the end + */ +{ + int n, k, len, col; + int idx, idxi, idxj; + SPROW *row, *rowi, *rowj, tmp_row; + row_elt *elt; + Real aii; + + n = A->n; + rowi = A->row + i; + rowj = A->row + j; + idxi = rowi->diag; + idxj = rowj->diag; + + swap->len = len = 0; + + /* + * build swap (new row i) + */ + + /* diagonal entry j to swap (i) */ + if (idxj >= 0) { + /* see if swap needs expanding */ + if (swap->maxlen == 0) { + swap = sprow_xpd(swap, 0, TYPE_SPMAT); + } + swap->elt[0].val = rowj->elt[idxj].val; + swap->elt[0].col = i; + swap->diag = 0; + len = 1; + idxj ++; + } + else { + swap->diag = -2; + idxj = INSERT_IDX(idxj); + } + + /* backing store diagonal entry of row i */ + if (idxi >= 0 && idxi < rowi->len) { + aii = rowi->elt[idxi].val; + idxi ++; + } + else { + aii = 0.0; + idxi = INSERT_IDX(idxi); + } + + /* exchange column j and row i for irow + k; + if (idxi < rowi->len) + col = rowi->elt[idxi].col; + else + col = n; + for (; k < j; k++, row++) { + idx = col_idxs->ive[k]; + + /* col j to swap (row i) */ + if (idx >= 0) { + /* see if swap needs expanding */ + if (swap->maxlen == len) { + swap->len = len; + swap = sprow_xpd(swap, 0, TYPE_SPMAT); + } + elt = swap->elt + len; + elt->val = row->elt[idx].val; + elt->col = k; + len ++; + } + + /* row i to col j */ + if (k == col && idxi < rowi->len) { + sp_set_val(A,k,j,rowi->elt[idxi].val); + idxi ++; + if (idxi < rowi->len) + col = rowi->elt[idxi].col; + else + col = n; + } + else if (idx >= 0) { + row->elt[idx].val = 0.0; + } + } + + /* element (i,j) from row i to swap */ + if (col == j && idxi < rowi->len) { + /* see if swap needs expanding */ + if (swap->maxlen == len) { + swap->len = len; + swap = sprow_xpd(swap, 0, TYPE_SPMAT); + } + elt = swap->elt + len; + elt->val = rowi->elt[idxi].val; + elt->col = j; + len ++; + idxi ++; + } + + /* row j (off the diagonal) onto swap (row i) */ + k = rowj->len - idxj; + if (k > 0) { + if (swap->maxlen < len + k) { + swap->len = len; + swap = sprow_xpd(swap, len + k, TYPE_SPMAT); + } + MEM_COPY((char *)(rowj->elt + idxj), (char *)(swap->elt + len), + k * sizeof(row_elt)); + len += k; + } + + swap->len = len; + + /* + * build new row j + */ + + /* diagonal entry aii to j */ + if (aii != 0.0) { + /* see if rowj needs expanding */ + if (rowj->maxlen == 0) { + rowj = sprow_xpd(rowj, 0, TYPE_SPMAT); + } + rowj->elt[0].val = aii; + rowj->elt[0].col = j; + rowj->diag = 0; + len = 1; + } + else { + rowj->diag = -2; + len = 0; + } + + /* resting row i onto row j */ + + k = rowi->len - idxi; + if (k > 0) { + if (rowj->maxlen < len + k) { + rowj->len = len; + rowj = sprow_xpd(rowj, len + k, TYPE_SPMAT); + } + MEM_COPY((char *)(rowi->elt + idxi), (char *)(rowj->elt + len), + k * sizeof(row_elt)); + len += k; + } + + rowj->len = len; + + /* + * exchange swap and old row i + */ + + MEM_COPY(rowi, &tmp_row, sizeof(SPROW)); + MEM_COPY(swap, rowi, sizeof(SPROW)); + MEM_COPY(&tmp_row, swap, sizeof(SPROW)); +} + + +SPMAT *spBKPfactor(SPMAT *A, PERM *pivot, Real tol) +/* + * -- factorize A in situ into P'AP = MDM' + * -- P(i+1) == 0 for (i,i+1) is a 2x2 block + */ +{ + int i, ip1, ip2, j, j1, k, k_end, n; + int idx, idx1, len; + Real aii, aip1, aiip1, lambda, sigma, tmp; + Real det, s, t; + SPMAT *swap_mat; + SPROW *row, *row1, *swap, tmp_row; + row_elt *elt, *elt1; + IVEC *col_idxs; + Real alpha; + + if (!A || !pivot) + error(E_NULL, "spBKPfactor"); + if (A->n != (int)pivot->size || A->n != A->m) + error(E_SIZES, "spBKPfactor"); + if (tol < 0.0 || tol > 1.0 ) + error(E_RANGE, "spBKPfactor"); + + alpha = tol * 0.6403882032022076; /* = tol * (1+sqrt(17))/8 */ + + n = A->n; + px_ident(pivot); + col_idxs = iv_get(n); + /* don't use sprow_get because of Meschach memory management */ + /* swap = sprow_get(MINROWLEN); */ + swap_mat = sp_get(1, n, MINROWLEN); + swap = swap_mat->row; + + if (!A->flag_diag) + sp_diag_access(A); + A->flag_col = 0; + + for (i = 0; i < n-1;) { + row = A->row + i; + ip1 = i+1; + ip2 = i+2; + + /* + * find the maximum element in the first column of the reduced + * matrix below the diagonal (go through first row as A is symmetric) + */ + idx = row->diag; + if (idx >= 0) { + elt = row->elt + idx; + aii = fabs(elt->val); + elt ++; + idx ++; + } + else { + idx = INSERT_IDX(idx); + elt = row->elt + idx; + aii = 0.0; + } + + lambda = aii; + j = i; + k_end = row->len; + for (; idx < k_end; idx++, elt++) { + tmp = fabs(elt->val); + if (tmp > lambda) { + j = elt->col; + lambda = tmp; + } + } + if (aii >= alpha * lambda) + goto onebyone; + + /* + * - determine the maximum element in the jth column of the + * reduced matrix off the diagonal + * - cache col indizes for interchange + */ + sigma = lambda; + k = ip1; + row = A->row + k; + for (; k < j; k++, row++) { + idx = sprow_idx(row, j); + col_idxs->ive[k] = idx; + if (idx >= 0) { + tmp = fabs(row->elt[idx].val); + if (tmp > sigma) + sigma = tmp; + } + } + row = A->row + j; + idx = row->diag; + if (idx >= 0) + idx ++; + else + idx = INSERT_IDX(idx); + elt = row->elt + idx; + k_end = row->len; + for (; idx < k_end; idx++, elt++) { + tmp = fabs(elt->val); + if (tmp > sigma) + sigma = tmp; + } + if (sigma * aii >= alpha * lambda * lambda) + goto onebyone; + + row = A->row + j; + idx = row->diag; + if (idx >= 0) + tmp = fabs(row->elt[idx].val); + else + tmp = 0.0; + if (tmp >= alpha * sigma) { + interchange(A, i, j, col_idxs, swap); + pivot->pe[i] = j; + goto onebyone; + } + + /* + * do 2x2 pivot + */ + row = A->row + i; + /* get element aii */ + idx = row->diag; + if (idx >= 0) { + aii = row->elt[idx].val; + idx ++; + } + else { + aii = 0.0; + idx = INSERT_IDX(idx); + } + /* perform row/col interchange; get element aiip1 */ + elt = row->elt + idx; + if (idx < row->len && elt->col == ip1) + aiip1 = elt->val; + else + aiip1 = 0.0; + if (j > ip1) { + interchange(A, ip1, j, col_idxs, swap); + /* exchange A[i][ip1] with A[i][j] */ + /* update A[i][j] first */ + idx1 = sprow_idx(row, j); + if (idx1 >= 0) { + tmp = row->elt[idx1].val; + row->elt[idx1].val = aiip1; + } + else { + tmp = 0.0; + /* fill in aiip1 */ + if (aiip1 != 0.0) + sprow_ins_val(row, idx1, aiip1, j, TYPE_SPMAT); + } + /* now update A[i][ip1] */ + aiip1 = tmp; + + elt = row->elt + idx; + if (idx < row->len && elt->col == ip1) { + elt->val = aiip1; + } + else { + /* fill in aiip1 */ + if (aiip1 != 0.0) + sprow_ins_val(row, idx, aiip1, ip1, TYPE_SPMAT); + } + } + /* set idx to next element after A[i][ip] */ + if (idx < row->len && row->elt[idx].col == ip1) { + idx ++; + } + pivot->pe[i] = j; + pivot->pe[ip1] = 0; + /* get A[ip1][ip1], set idx1 behind it */ + row1 = A->row + ip1; + idx1 = row1->diag; + if (idx1 >= 0) { + aip1 = row1->elt[idx1].val; + idx1 ++; + } + else { + aip1 = 0.0; + idx1 = INSERT_IDX(idx1); + } + det = aii * aip1 - aiip1 * aiip1; + aii /= det; + aiip1 /= det; + aip1 /= det; + + j = (idx < row->len)? row->elt[idx].col: n; + j1 = (idx1 < row1->len)? row1->elt[idx1].col: n; + while (j < n || j1 < n) { + if (j < j1) { + elt = row->elt + idx; + s = aip1 * elt->val; + t = - aiip1 * elt->val; + spbkp_mltadd2(A->row+j, row, idx, -s, + row1, INSERT_IDX(idx1), -t, swap, TYPE_SPMAT); + elt->val = s; + idx ++; + if (t != 0.0) { + sprow_ins_val(row1, idx1, t, j, TYPE_SPMAT); + idx1 ++; + } + } + else if (j1 < j) { + elt1 = row1->elt + idx1; + s = - aiip1 * elt1->val; + t = aii * elt1->val; + spbkp_mltadd2(A->row+j1, row, INSERT_IDX(idx), -s, + row1, idx1, -t, swap, TYPE_SPMAT); + if (s != 0.0) { + sprow_ins_val(row, idx, s, j1, TYPE_SPMAT); + idx ++; + } + elt1->val = t; + idx1 ++; + } + else { /* j == j1 */ + elt = row->elt + idx; + elt1 = row1->elt + idx1; + s = - aiip1 * elt1->val + aip1 * elt->val; + t = - aiip1 * elt->val + aii * elt1->val; + spbkp_mltadd2(A->row+j, row, idx, -s, + row1, idx1, -t, swap, TYPE_SPMAT); + elt->val = s; + idx ++; + elt1->val = t; + idx1 ++; + } + j = (idx < row->len)? row->elt[idx].col: n; + j1 = (idx1 < row1->len)? row1->elt[idx1].col: n; + } + + i = ip2; + continue; + + onebyone: + /* + * do 1x1 pivot + */ + row = A->row + i; + idx = row->diag; + if (idx >= 0) { + aii = row->elt[idx].val; + idx ++; + } + else { + aii = 0.0; + idx = INSERT_IDX(idx); + } + if (aii != 0.0) { + elt = row->elt + idx; + len = row->len; + for (; idx < len; idx++, elt++) { + j = elt->col; + s = elt->val / aii; + if (s != 0.0) { + spbkp_mltadd(A->row+j, row, idx, -s, swap, TYPE_SPMAT); + /* exchange swap with row #j */ + MEM_COPY(A->row+j, &tmp_row, sizeof(SPROW)); + MEM_COPY(swap, A->row+j, sizeof(SPROW)); + MEM_COPY(&tmp_row, swap, sizeof(SPROW)); + } + elt->val = s; + } + } + + i = ip1; + } + + iv_free(col_idxs); + /* sprow_free(swap); */ + sp_free(swap_mat); + + A->flag_diag = 1; + + return A; +} + +VEC *spBKPsolve(const SPMAT *A, const PERM *pivot, const VEC *b, VEC *x) +/* + * - solve A*x = b after A has been factorized by spBKPfactor + * - raise an E_SING if A is singular + */ +{ + int i, ii, k, ip1; + int n, idx, idx1, len; + Real det, tmp, save; + Real aiip1, aii, aip1; + Real *x_ve; + u_int *p_pe; + SPROW *row, *row1; + row_elt *elt; + + if (!A || !pivot || !b) + error(E_NULL, "spBKPsolve"); + if (!A->flag_diag) + error(E_FORMAT, "spBKPsolve"); + n = A->n; + if ((int)b->dim != n || (int)pivot->size != n || A->n != A->m) + error(E_SIZES, "spBKPsolve"); + if (!x || (int)x->dim != n) + x = v_resize(x,n); + + p_pe = pivot->pe; + + /* + * solve MDy = b for y, where b is stored in x and store y in x + */ + + x = v_copy(b,x); + x_ve = x->ve; + for (i = 0; i < n-1;) { + row = A->row + i; + row1 = row + 1; + ip1 = i+1; + save = x_ve[p_pe[i]]; + idx = row->diag; + if (idx >= 0) { + aii = row->elt[idx].val; + idx ++; + } + else { + aii = 0.0; + idx = INSERT_IDX(idx); + } + if (p_pe[ip1] > 0) { + /* + * 1x1 pivot + */ + x_ve[p_pe[i]] = x_ve[i]; + if (aii == 0.0) + error(E_SING, "spBKPsolve"); + x_ve[i] = save / aii; + elt = row->elt + idx; + len = row->len; + for (; idx < len; idx++, elt++) { + x_ve[elt->col] -= save * elt->val; + } + i = ip1; + } + else { + /* + * 2x2 pivot + */ + tmp = x_ve[i]; + x_ve[p_pe[i]] = x_ve[ip1]; + if (row->elt[idx].col == ip1) { + aiip1 = row->elt[idx].val; + idx ++; + } + else + aiip1 = 0.0; + idx1 = row1->diag; + if (idx1 >= 0) { + aip1 = row1->elt[idx1].val; + idx1 ++; + } + else { + aip1 = 0.0; + idx1 = INSERT_IDX(idx1); + } + det = aii * aip1 - aiip1 * aiip1; + if (det == 0.0) + error(E_SING, "spBKPsolve"); + x_ve[i] = (tmp * aip1 - save * aiip1) / det; + x_ve[ip1] = (save * aii - tmp * aiip1) / det; + elt = row->elt + idx; + len = row->len; + for (; idx < len; idx++, elt++) { + x_ve[elt->col] -= tmp * elt->val; + } + elt = row1->elt + idx1; + len = row1->len; + for (; idx1 < len; idx1++, elt++) { + x_ve[elt->col] -= save * elt->val; + } + i += 2; + } + } + if (i == n-1) { + row = A->row + i; + idx = row->diag; + if (idx >= 0) + aii = row->elt[idx].val; + else + aii = 0.0; + if (aii == 0.0) + error(E_SING, "spBKPsolve"); + x_ve[i] /= aii; + i = n - 2; + } + else + i = n - 3; + + /* + * solve M'x = y for x, where y is stored in x + */ + while (i >= 0) { + ip1 = i + 1; + if (p_pe[i] > 0 || i == 0) + ii = i; /* 1x1 pivot */ + else + ii = i-1; /* 2x2 pivot */ + for (k = ii; k <= i; k++) { + tmp = x_ve[k]; + row = A->row + k; + idx = row->diag; + idx = (idx < 0)? INSERT_IDX(idx): idx; + elt = row->elt + idx; + len = row->len; + /* go to index i+1 */ + while (idx < len && elt->col < ip1) { + idx ++; + elt ++; + } + for (; idx < len; idx++, elt++) + tmp -= elt->val * x_ve[elt->col]; + x_ve[k] = tmp; + } + if (i != (int)p_pe[ii]) { + tmp = x_ve[i]; + x_ve[i] = x_ve[p_pe[ii]]; + x_ve[p_pe[ii]] = tmp; + } + i = ii - 1; + } + + return x; +} diff --git a/hqp/sprcm.C b/hqp/sprcm.C new file mode 100644 index 0000000..a646ce5 --- /dev/null +++ b/hqp/sprcm.C @@ -0,0 +1,701 @@ +/* + * Reverse Cuthill McKee ordering of sparse matrices and KKT systems. + * + * rf, 11/15/95 + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include + +#include "Meschach.h" + +/* + * define a struct to describe a node + */ +typedef struct Node { + int node; /* position of the node in the original matrix */ + int deg; /* degree of the node */ + int deg2; /* sum of degrees of the node's neighbours */ +} Node; + +/* + * compare two nodes + */ +static int cmpNode(const Node *n1, const Node *n2) +{ + int ret; + ret = n1->deg - n2->deg; + if (ret == 0) { + ret = n1->deg2 - n2->deg2; + } + return ret; +} + +/* + * sp_rcm_scan: + * -- analyze sparsity pattern of a Kuhn-Tucker-system + * Q A'C' + * A + * C + * -- A or C may be NULL + * -- only the upper diagonal part is inspected + * -- allocate and return concatted list of neighbours of all nodes + */ +IVEC *sp_rcm_scan(const SPMAT *Q, const SPMAT *A, const SPMAT *C, + IVEC *degree, IVEC *neigh_start, IVEC *neighs) +{ + int i, i_end, j, j_idx, j_end, n, offs; + int *d_ive, *s_ive, *n_ive; + SPROW *row; + row_elt *elt; + + if (!Q || !degree || !neigh_start) + error(E_NULL, "sp_rcm_scan"); + if (Q->n != Q->m) + error(E_SIZES, "sp_rcm_scan"); + + n = Q->n; + if (A) + n += A->m; + if (C) + n += C->m; + + if ((int)degree->dim != n || (int)neigh_start->dim != n + 1) + error(E_SIZES, "sp_rcm_scan"); + + /* + * first pass: + * -- go through Q,A,C and count neighbours of each node (degree) + * -- initialize neigh_start to point into neighs + * -- allocate neighs + */ + + iv_zero(degree); + + d_ive = degree->ive; + s_ive = neigh_start->ive; + + row = Q->row; + i_end = Q->m; + for (i = 0; i < i_end; i++, row++) { + elt = row->elt; + j_end = row->len; + for (j_idx = 0; j_idx < j_end; j_idx++, elt++) { + j = elt->col; + if (j > i) { + d_ive[i] ++; + d_ive[j] ++; + } + } + } + + if (A) { + offs = Q->n; + row = A->row; + i_end = offs + A->m; + for (i = offs; i < i_end; i++, row++) { + elt = row->elt; + j_end = row->len; + for (j_idx = 0; j_idx < j_end; j_idx++, elt++) { + j = elt->col; + d_ive[i] ++; + d_ive[j] ++; + } + } + } + + if (C) { + offs = Q->n; + if (A) + offs += A->m; + row = C->row; + i_end = offs + C->m; + for (i = offs; i < i_end; i++, row++) { + elt = row->elt; + j_end = row->len; + for (j_idx = 0; j_idx < j_end; j_idx++, elt++) { + j = elt->col; + d_ive[i] ++; + d_ive[j] ++; + } + } + } + + offs = 0; + for (i = 0; i < n; i++) { + s_ive[i] = offs; + offs += d_ive[i]; + d_ive[i] = 0; + } + s_ive[n] = offs; + + neighs = iv_resize(neighs, offs); + n_ive = neighs->ive; + + /* + * second pass: + * -- initialize neighs as a concatted list of neighbours of all nodes + */ + + row = Q->row; + i_end = Q->m; + for (i = 0; i < i_end; i++, row++) { + elt = row->elt; + j_end = row->len; + for (j_idx = 0; j_idx < j_end; j_idx++, elt++) { + j = elt->col; + if (j > i) { + n_ive[s_ive[i] + d_ive[i]] = j; + n_ive[s_ive[j] + d_ive[j]] = i; + d_ive[i] ++; + d_ive[j] ++; + } + } + } + + if (A) { + offs = Q->n; + row = A->row; + i_end = offs + A->m; + for (i = offs; i < i_end; i++, row++) { + elt = row->elt; + j_end = row->len; + for (j_idx = 0; j_idx < j_end; j_idx++, elt++) { + j = elt->col; + n_ive[s_ive[i] + d_ive[i]] = j; + n_ive[s_ive[j] + d_ive[j]] = i; + d_ive[i] ++; + d_ive[j] ++; + } + } + } + + if (C) { + offs = Q->n; + if (A) + offs += A->m; + row = C->row; + i_end = offs + C->m; + for (i = offs; i < i_end; i++, row++) { + elt = row->elt; + j_end = row->len; + for (j_idx = 0; j_idx < j_end; j_idx++, elt++) { + j = elt->col; + n_ive[s_ive[i] + d_ive[i]] = j; + n_ive[s_ive[j] + d_ive[j]] = i; + d_ive[i] ++; + d_ive[j] ++; + } + } + } + + return neighs; +} + +/* + * Find Reverse-Cuthill-McKee order for a sparse matrix + * given by a concatted list of neighbours of all nodes. + * degree: number of neighbours for n nodes + * neigh_start: start index into neighs for each node i, 0 <= i <= n + * (neigh_start->ive[n] is the first free index) + * neighs: concatted list of neighbours of n nodes + * order: determined permutation + * + * Reference: + * J. Weissinger. Sp"arlich besetzte Gleichungssysteme, + * Wissenschaftsverlag, Mannheim, 1990. + */ +PERM *sp_rcm_order(const IVEC *degree, const IVEC *neigh_start, + const IVEC *neighs, PERM *order) +{ + int n, root; + int count, node; + char *marks; + char *glob_marks; + Node *levels; + int *n_ive, *s_ive, *d_ive; + int l_begin, l_end; + int nlevels, nlevels_old; + int i, j, j_end, k, k_end; + int deg; + int cluster_start; + + if (!degree || !neigh_start || !neighs) + error(E_NULL, "sp_rcm_order"); + n = degree->dim; + if (n + 1 != (int)neigh_start->dim + || neigh_start->ive[n] != (int)neighs->dim) + error(E_SIZES, "sp_rcm_order"); + + if (!order || (int)order->size != n) + order = px_resize(order, n); + + marks = (char *)malloc(n); + glob_marks = (char *)malloc(n); + levels = (Node *)calloc(n, sizeof(Node)); + if (!marks || !glob_marks || !levels) + error(E_MEM, "sp_rcm_order"); + + n_ive = neighs->ive; + s_ive = neigh_start->ive; + d_ive = degree->ive; + + for (i = 0; i < n; i++) + glob_marks[i] = 1; + root = 0; + count = 0; + + while (root < n) { + + nlevels = 0; + cluster_start = count; + + do { /* ... while (nlevels > nlevels_old) */ + + /* find level structure for current root node */ + + count = cluster_start; + + for (i = 0; i < n; i++) + marks[i] = glob_marks[i]; + + nlevels_old = nlevels; + nlevels = 0; + l_begin = count; + l_end = count; + levels[count++].node = root; /* add root node */ + marks[root] = 0; /* unmark root node */ + /* decrement degree of neighbours */ + k_end = s_ive[root + 1]; + for (k = s_ive[root]; k < k_end; k++) { + d_ive[n_ive[k]]--; + } + + do { /* while (count > l_end) */ + + /* add nodes for the next level */ + + l_begin = l_end; + l_end = count; + nlevels ++; + for (i = l_begin; i < l_end; i++) { + node = levels[i].node; + j_end = s_ive[node + 1]; + for (j = s_ive[node]; j < j_end; j++) { + node = n_ive[j]; + if (marks[node]) { + levels[count++].node = node; /* add node */ + marks[node] = 0; /* unmark added node */ + /* decrement degree of neighbours */ + k_end = s_ive[node + 1]; + for (k = s_ive[node]; k < k_end; k++) { + d_ive[n_ive[k]]--; + } + } + } + + /* + * complete nodes of current level with degrees and sort them + */ + + if (count - l_end > 1) { + for (k = l_end; k < count; k++) { + node = levels[k].node; + levels[k].deg = d_ive[node]; + deg = 0; + j_end = s_ive[node + 1]; + for (j = s_ive[node]; j < j_end; j++) { + if (marks[n_ive[j]]) { + deg += d_ive[n_ive[j]]; + } + } + levels[k].deg2 = deg; + } + + qsort( (void *)(levels + l_end), + count - l_end, sizeof(Node), + (int (*)(const void *, const void *))cmpNode); + } + } + } while (count > l_end); + + if (nlevels_old > nlevels) + warning(WARN_UNKNOWN, "sp_rcm_order: Levels decreased!"); + + /* + * choose the node with the smallest degree in the last level + * as root for the next iteration + */ + root = levels[l_begin].node; + deg = d_ive[root]; + for (i = l_begin + 1; i < l_end; i++) { + if (d_ive[levels[i].node] < deg) { + root = levels[i].node; + deg = d_ive[root]; + } + } + + /* restore degree */ + for (i = 0; i < n; i++) + d_ive[i] = s_ive[i + 1] - s_ive[i]; + + } while (nlevels > nlevels_old); + + root = n; + for (i = 0; i < n; i++) { + glob_marks[i] = marks[i]; + if (marks[i]) + root = i; + } + } + + /* + * fill order + * -- order->pe[i] says, where to put row/col i into the reordered matrix + * -- order is reverted + */ + + for (i = 0; i < n; i++) + order->pe[levels[i].node] = n - i - 1; + + free(levels); + free(glob_marks); + free(marks); + + return order; +} + +/* + * sp_rcm_sbw: + * -- return semi band width according order + * (the number of upper diagonals) + */ +int sp_rcm_sbw(const IVEC *neigh_start, const IVEC *neighs, const PERM *order) +{ + int i, i_idx, n; + int j_idx, j_end; + int max_neigh; + int ub; + int node, dist; + int *n_ive, *s_ive; + + n = order->size; + n_ive = neighs->ive; + s_ive = neigh_start->ive; + + ub = 0; + for (i_idx = 0; i_idx < n; i_idx++) { + i = order->pe[i_idx]; + max_neigh = i; + j_end = s_ive[i_idx + 1]; + for (j_idx = s_ive[i_idx]; j_idx < j_end; j_idx++) { + node = order->pe[n_ive[j_idx]]; + if (node > max_neigh) + max_neigh = node; + } + dist = max_neigh - i; + if (dist > ub) + ub = dist; + } + + return ub; +} + +/* + * sp_symrcm: + * -- analyze sparsity pattern of symmetric matrix Q + * and return Reverse-Cuthil-McKee order + * -- only the upper diagonal part of Q is inspected + */ +PERM *sp_symrcm(const SPMAT *Q, PERM *order) +{ + int n; + IVEC *degree, *neigh_start, *neighs; + + if (!Q) + error(E_NULL, "sp_symrcm"); + n = Q->n; + if (n != Q->m) + error(E_SIZES, "sp_symrcm"); + + degree = iv_get(n); + neigh_start = iv_get(n + 1); + neighs = sp_rcm_scan(Q, SMNULL, SMNULL, degree, neigh_start, IVNULL); + + order = sp_rcm_order(degree, neigh_start, neighs, order); + + iv_free(degree); + iv_free(neigh_start); + iv_free(neighs); + + return order; +} + +/* + * sp_kktrcm: + * -- analyze sparsity pattern of symmetric Kuhn-Tucker-system + * and return Reverse-Cuthil-McKee order + * -- only the upper diagonal part is inspected + */ +PERM *sp_kktrcm(const SPMAT *Q, const SPMAT *A, const SPMAT *C, + PERM *order) +{ + int n; + IVEC *degree, *neigh_start, *neighs; + + if (!Q) + error(E_NULL, "sp_kktrcm"); + if (Q->n != Q->m) + error(E_SIZES, "sp_kktrcm"); + + n = Q->n; + if (A) + n += A->m; + if (C) + n += C->m; + + degree = iv_get(n); + neigh_start = iv_get(n + 1); + neighs = sp_rcm_scan(Q, A, C, degree, neigh_start, IVNULL); + + order = sp_rcm_order(degree, neigh_start, neighs, order); + + iv_free(degree); + iv_free(neigh_start); + iv_free(neighs); + + return order; +} + +/* + * sp_copy_rcm: + * -- copy src into dst + * -- the structure of dst is destroyed (in contrast to sp_copy2) + */ +static SPMAT *sp_copy_rcm(const SPMAT *src, SPMAT *dst) +{ + SPROW *rs, *rd; + int i, n, m; + + if (!src) + error(E_NULL, "sp_copy_rcm"); + n = src->n; + m = src->m; + if (!dst || dst->n != n || dst->m != m) + dst = sp_resize(dst, m, n); + + rd = dst->row; + rs = src->row; + for (i=0; imaxlen < rs->len) + sprow_resize(rd, rs->len, TYPE_SPMAT); + rd->len = rs->len; + rd->diag = rs->diag; + MEM_COPY(rs->elt, rd->elt, rs->len * sizeof(row_elt)); + } + + dst->flag_col = src->flag_col; + dst->flag_diag = src->flag_diag; + + return dst; +} + +/* + * pxinv_spcols: + * -- permute columns of a sparse matrix + * dst = src * px' + */ + +static int cmp_row_elt(const row_elt *elt1, const row_elt *elt2) +{ + int ret; + ret = elt1->col - elt2->col; + if (ret == 0) + /* invalid multiple occurence of same column index */ + error(E_INTERN, "pxinv_spcols"); + return ret; +} + +SPMAT *pxinv_spcols(const PERM *px, const SPMAT *src, SPMAT *dst) +{ + int i, j_idx, len, m; + SPROW *row; + row_elt *elt; + + if (!src || !px) + error(E_NULL, "pxinv_spcols"); + m = src->m; + if (m != (int)px->size) + error(E_SIZES, "pxinv_spcols"); + + /* + * copy src into dst + */ + + if (dst != src) { + if (!dst) + dst = sp_copy(src); + else + dst = sp_copy_rcm(src, dst); + } + + /* + * perform permutation in situ + * (insert new column indezes and sort row entries) + */ + + dst->flag_diag = 0; + + row = dst->row; + for (i = 0; i < m; i++, row++) { + len = row->len; + elt = row->elt; + for (j_idx = 0; j_idx < len; j_idx++, elt++) + elt->col = px->pe[elt->col]; + if (len > 1) + qsort(row->elt, len, sizeof(row_elt), + (int (*)(const void *, const void *))cmp_row_elt); + } + + return dst; +} + +/* + * pxinv_sprows: + * -- permute rows of a sparse matrix + * dst = px' * src + */ +SPMAT *pxinv_sprows(const PERM *px, const SPMAT *src, SPMAT *dst) +{ + int start, size, i, i_new, m; + SPROW tmp, tmp_new; + + if (!src || !px) + error(E_NULL, "pxinv_sprows"); + m = src->m; + size = px->size; + if (m != size) + error(E_SIZES, "pxinv_sprows"); + + /* + * copy src into dst + */ + + if (dst != src) { + if (!dst) + dst = sp_copy(src); + else + dst = sp_copy_rcm(src, dst); + } + + if (size == 0) + return dst; + + /* + * perform permutation in situ + */ + + dst->flag_col = dst->flag_diag = 0; + + start = 0; + do { + tmp_new = dst->row[start]; + i_new = start; + do { + i = i_new; + i_new = px->pe[i]; + if (i_new >= size) + /* invalid multiple occurence of same row index */ + error(E_INTERN, "pxinv_sprows"); + if (i != i_new) { + tmp = tmp_new; + tmp_new = dst->row[i_new]; + dst->row[i_new] = tmp; + } + px->pe[i] += size; + } while (i_new != start); + for (start = 0; (int)px->pe[start] >= size && start < size; start++); + } while (start < size); + + for (i = 0; i < size; i++) + px->pe[i] -= size; + + return dst; +} + +/* + * pxinv_vec: + * -- permute a vector + * dst = px' * src + */ +VEC *pxinv_vec(const PERM *px, const VEC *src, VEC *dst) +{ + int start, size, i, i_new, dim; + Real tmp, tmp_new; + + if (!px || !src) + error(E_NULL, "pxinv_vec"); + dim = src->dim; + size = px->size; + if (dim != size) + error(E_SIZES, "pxinv_vec"); + + /* + * copy src into dst + */ + + if (dst != src) { + dst = v_copy(src, dst); + dst->dim = src->dim; + } + + /* + * perform permutation in situ + */ + + if (size == 0) + return dst; + + start = 0; + do { + tmp_new = dst->ve[start]; + i_new = start; + do { + i = i_new; + i_new = px->pe[i]; + if (i_new >= size) + /* invalid multiple occurence of same row index */ + error(E_INTERN, "pxinv_vec"); + if (i != i_new) { + tmp = tmp_new; + tmp_new = dst->ve[i_new]; + dst->ve[i_new] = tmp; + } + px->pe[i] += size; + } while (i_new != start); + for (start = 0; (int)px->pe[start] >= size && start < size; start++); + } while (start < size); + + for (i = 0; i < size; i++) + px->pe[i] -= size; + + return dst; +} diff --git a/hqp/sprcm.h b/hqp/sprcm.h new file mode 100644 index 0000000..ed0980a --- /dev/null +++ b/hqp/sprcm.h @@ -0,0 +1,67 @@ +/* + * Copyright (C) 1995 R"udiger Franke, all rights reserved. + * + * This code is based on the Meschach library (Copyright (C) 1993 + * David E. Steward & Zbigniew Leyk, all rights reserved.). + * The Meschach copyright conditions, as included bolow, extend to it. + * + ************************************************************************** + * + * Meschach Library + * + * This Meschach Library is provided "as is" without any express + * or implied warranty of any kind with respect to this software. + * In particular the authors shall not be liable for any direct, + * indirect, special, incidental or consequential damages arising + * in any way from use of the software. + * + * Everyone is granted permission to copy, modify and redistribute this + * Meschach Library, provided: + * 1. All copies contain this copyright notice. + * 2. All modified copies shall carry a notice stating who + * made the last modification and the date of such modification. + * 3. No charge is made for this software or works derived from it. + * This clause shall not be construed as constraining other software + * distributed on the same medium as this software, nor is a + * distribution fee considered a charge. + * + ************************************************************************** + * + * function prototypes for Reverse Cuthill McKee ordering of sparse matrices + * + * rf, 11/15/95 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +PERM *sp_symrcm(const SPMAT *Q, PERM *order); +PERM *sp_kktrcm(const SPMAT *Q, const SPMAT *A, const SPMAT *C, + PERM *order); + +SPMAT *pxinv_sprows(const PERM *px, const SPMAT *src, SPMAT *dst); +SPMAT *pxinv_spcols(const PERM *px, const SPMAT *src, SPMAT *dst); + +VEC *pxinv_vec(const PERM *px, const VEC *src, VEC *dst); + +IVEC *sp_rcm_scan(const SPMAT *Q, const SPMAT *A, const SPMAT *C, + IVEC *degree, IVEC *neigh_start, IVEC *neighs); +PERM *sp_rcm_order(const IVEC *degree, const IVEC *neigh_start, + const IVEC *neighs, PERM *order); +int sp_rcm_sbw(const IVEC *neigh_start, const IVEC *neighs, const PERM *order); diff --git a/hqp/t_mesch.C b/hqp/t_mesch.C new file mode 100644 index 0000000..904f4cd --- /dev/null +++ b/hqp/t_mesch.C @@ -0,0 +1,260 @@ +/* + * t_mesch.C -- + * - 'time-dependent' Meschach data structures: + * + * TVECP - vector of VECP + * TIVECP - vector of IVECP + * PERMP - PERM * + * TPERMP - vector of PERMP + * TMATP - vector of MATP + * + * E. Arnold 03/07/97 + * 07/03/97: _x[k] = VNULL etc + * + */ + +/* + Copyright (C) 1997--1998 Eckhard Arnold + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include "t_mesch.h" + +//---------- TVECP ---------- + +TVECP::TVECP() +{ + _kmax = -1; + _x = NULL; +} + +TVECP::~TVECP() +{ + free(); +} + +void TVECP::free() +{ + int k; + for (k = 0; k <= _kmax; k++) + V_FREE(_x[k]); + if ( _x ) { + delete _x; + _x = NULL; + } + _kmax = -1; +} + +void TVECP::resize(int kmax, int n) +{ + int k; + if ( ( kmax <= 0 ) || ( n < 0 ) ) + error(E_BOUNDS,"TVECP::resize"); + if ( ( _kmax != -1 ) && ( _kmax != kmax ) ) + free(); + if ( _kmax == -1 ) { + _kmax = kmax; + _x = new VECP[_kmax+1]; + if ( _x == NULL ) + error(E_MEM,"TVECP::resize"); + for ( k = 0; k <= _kmax; k++ ) + _x[k] = VNULL; + } + for ( k = 0; k <= _kmax; k++ ) { + if ( ( n == 0) && ( (VEC *) _x[k] == VNULL ) ) + _x[k] = v_resize(_x[k], 1); // it's not a bug, it's a feature! + _x[k] = v_resize(_x[k], n); + } +} + +void TVECP::Print() +{ + int k; + for (k = 0; k <= _kmax; k++) { + printf("k = %d\n", k); + v_output(_x[k]); + } +} + +//---------- TIVECP ---------- + +TIVECP::TIVECP() +{ + _kmax = -1; + _x = NULL; +} + +TIVECP::~TIVECP() +{ + free(); +} + +void TIVECP::free() +{ + int k; + for (k = 0; k <= _kmax; k++) + IV_FREE(_x[k]); + if ( _x ) { + delete _x; + _x = NULL; + } + _kmax = -1; +} + +void TIVECP::resize(int kmax, int n) +{ + int k; + if ( ( kmax <= 0 ) || ( n < 0 ) ) + error(E_BOUNDS,"TIVECP::resize"); + if ( ( _kmax != -1 ) && ( _kmax != kmax ) ) + free(); + if ( _kmax == -1 ) { + _kmax = kmax; + _x = new IVECP[_kmax+1]; + if ( _x == NULL ) + error(E_MEM,"TIVECP::resize"); + for ( k = 0; k <= _kmax; k++ ) + _x[k] = IVNULL; + } + for ( k = 0; k <= _kmax; k++ ) { + if ( ( n == 0) && ( (IVEC *) _x[k] == IVNULL ) ) + _x[k] = iv_resize(_x[k], 1); // it's not a bug, it's a feature! + _x[k] = iv_resize(_x[k], n); + } +} + +void TIVECP::Print() +{ + int k; + for (k = 0; k <= _kmax; k++) { + printf("k = %d\n", k); + iv_output(_x[k]); + } +} + +//---------- TPERMP ---------- + +TPERMP::TPERMP() +{ + _kmax = -1; + _x = NULL; +} + +TPERMP::~TPERMP() +{ + free(); +} + +void TPERMP::free() +{ + int k; + for (k = 0; k <= _kmax; k++) + PX_FREE(_x[k]); + if ( _x ) { + delete _x; + _x = NULL; + } + _kmax = -1; +} + +void TPERMP::resize(int kmax, int n) +{ + int k; + if ( ( kmax <= 0 ) || ( n < 0 ) ) + error(E_BOUNDS,"TPERMP::resize"); + if ( ( _kmax != -1 ) && ( _kmax != kmax ) ) + free(); + if ( _kmax == -1 ) { + _kmax = kmax; + _x = new PERMP[_kmax+1]; + if ( _x == NULL ) + error(E_MEM,"TPERMP::resize"); + for ( k = 0; k <= _kmax; k++ ) + _x[k] = PNULL; + } + for ( k = 0; k <= _kmax; k++ ) { + if ( ( n == 0) && ( (PERM *) _x[k] == PNULL ) ) + _x[k] = px_resize(_x[k], 1); // it's not a bug, it's a feature! + _x[k] = px_resize(_x[k], n); + } +} + +void TPERMP::Print() +{ + int k; + for (k = 0; k <= _kmax; k++) { + printf("k = %d\n", k); + px_output(_x[k]); + } +} + +//---------- TMATP ---------- + +TMATP::TMATP() +{ + _kmax = -1; + _x = NULL; +} + +TMATP::~TMATP() +{ + free(); +} + +void TMATP::free() +{ + int k; + for (k = 0; k <= _kmax; k++) + M_FREE(_x[k]); + if ( _x ) { + delete _x; + _x = NULL; + } + _kmax = -1; +} + +void TMATP::resize(int kmax, int m, int n) +{ + int k; + if ( ( kmax <= 0 ) || ( n < 0 ) || ( m < 0 ) ) + error(E_BOUNDS,"TMATP:resize"); + if ( ( _kmax != -1 ) && ( _kmax != kmax ) ) + free(); + if ( _kmax == -1 ) { + _kmax = kmax; + _x = new MATP[_kmax+1]; + if ( _x == NULL ) + error(E_MEM,"TMATP::resize"); + for ( k = 0; k <= _kmax; k++ ) + _x[k] = MNULL; + } + for ( k = 0; k <= _kmax; k++ ) { + if ( ( ( n == 0) || ( m == 0 ) ) && ( (MAT *) _x[k] == MNULL ) ) + _x[k] = m_resize(_x[k], 1, 1); // it's not a bug, it's a feature! + _x[k] = m_resize(_x[k], m, n); + } +} + +void TMATP::Print() +{ + int k; + for (k = 0; k <= _kmax; k++) { + printf("k = %d\n", k); + m_output(_x[k]); + } +} + diff --git a/hqp/t_mesch.h b/hqp/t_mesch.h new file mode 100644 index 0000000..b8f8de1 --- /dev/null +++ b/hqp/t_mesch.h @@ -0,0 +1,141 @@ +/* + * t_mesch.h -- + * - 'time-dependent' Meschach data structures: + * + * TVECP - vector of VECP + * TIVECP - vector of IVECP + * PERMP - PERM * + * TPERMP - vector of PERMP + * TMATP - vector of MATP + * + * E. Arnold 07/03/97 + * + */ + +/* + Copyright (C) 1997--1998 Eckhard Arnold + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + + +#ifndef T_MESCH_H +#define T_MESCH_H + +#include "Meschach.h" + +//---------- TVECP ---------- + +class TVECP { + + private: + int _kmax; + VECP *_x; + + public: + TVECP(); + ~TVECP(); + void free(); + void resize(int, int = 0); + void resize(const IVECP); + VECP & operator [] (int k) + { +#ifdef DEBUG + if ( ( k < 0 ) || ( k > _kmax ) ) + error(E_BOUNDS,"TVECP::operator[]"); +#endif + return _x[k]; + } + void Print(); + void Print(char *s) { printf("TVECP %s\n", s); Print(); } +}; + +//---------- TIVECP ---------- + +class TIVECP { + + private: + int _kmax; + IVECP *_x; + + public: + TIVECP(); + ~TIVECP(); + void free(); + void resize(int, int = 0); + IVECP & operator [] (int k) + { +#ifdef DEBUG + if ( ( k < 0 ) || ( k > _kmax ) ) + error(E_BOUNDS,"TIVECP::operator[]"); +#endif + return _x[k]; + } + void Print(); + void Print(char *s) { printf("TIVECP %s\n", s); Print(); } +}; + +//---------- TPERMP ---------- + +class TPERMP { + + private: + int _kmax; + PERMP *_x; + + public: + TPERMP(); + ~TPERMP(); + void free(); + void resize(int, int = 0); + PERMP & operator [] (int k) + { +#ifdef DEBUG + if ( ( k < 0 ) || ( k > _kmax ) ) + error(E_BOUNDS,"TPERMP::operator[]"); +#endif + return _x[k]; + } + void Print(); + void Print(char *s) { printf("TPERMP %s\n", s); Print(); } +}; + +//---------- TMATP ---------- + +class TMATP { + + private: + int _kmax; + MATP *_x; + + public: + TMATP(); + ~TMATP(); + void free(); + void resize(int, int = 0, int = 0); + MATP & operator [] (int k) + { +#ifdef DEBUG + if ( ( k < 0 ) || ( k > _kmax ) ) + error(E_BOUNDS,"TMATP::operator[]"); +#endif + return _x[k]; + } + void Print(); + void Print(char *s) { printf("TMATP %s\n", s); Print(); } +}; + +#endif diff --git a/hqp/tpc.c b/hqp/tpc.c new file mode 100644 index 0000000..71053cd --- /dev/null +++ b/hqp/tpc.c @@ -0,0 +1,236 @@ +/* tpc.c -- + * - build from Tcl scripts a c_file with a global string + * - usage: tpc [-o ] [-ts ] tcl_file ... + * - default c_file: tpc.out + * + * Copyright (c) 1994 R"udiger Franke + * All Rights Reserved. + * + * Redistribution and use in any form, with or without modification, + * is permitted, provided that the following conditions are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in other form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. All advertising materials mentioning features or use of this software + * must display the following acknowledgement: + * This product includes software developed by R"udiger Franke. + * 4. The name of the author may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +#include +#include +#include + + +int main (int argc, char *argv[]) +{ + char *outputFile; + int tsize; + FILE *in, *out; + int argnum; + int c, index, written; + int linestart; + + /* + * usage + */ + + if (argc == 1) { + printf ("usage:"); + printf (" tpc [-o ] [-ts ] tcl_file ...\n"); + return 0; + } + + /* + * parse command line options + * (don't use getopt() to get rid of unistd.h) + */ + + outputFile = "tpc.out"; + tsize = -1; + + argnum = 1; + while (argc > argnum && argv[argnum][0] == '-') { + if (strncmp(argv[argnum], "-o", 2) == 0) { + if (strlen(argv[argnum]) > 2) { + outputFile = &argv[argnum][2]; + argnum ++; + } + else { + if (argc > argnum + 1) { + outputFile = argv[argnum+1]; + argnum += 2; + } else { + fprintf (stderr, "tpc: missing file name for -o\n"); + return -1; + } + } + } + else if (strncmp(argv[argnum], "-ts", 3) == 0) { + if (strlen(argv[argnum]) > 3) { + tsize = atoi(&argv[argnum][3]); + argnum ++; + } + else { + if (argc > argnum + 1) { + tsize = atoi(argv[argnum+1]); + argnum += 2; + } else { + fprintf (stderr, "tpc: missing token size for -ts\n"); + return -1; + } + } + } + else { + fprintf (stderr, "tpc: unknown option \"%s\".\n", argv[argnum]); + return -1; + } + } + + if (argc == argnum) { + fprintf(stderr, "tpc: no input files specified.\n"); + return -1; + } + + /* + * open output file, write variable declaration + */ + + if ((out= fopen (outputFile, "w")) == NULL) { + fprintf (stderr, "tpc: open output file %s", outputFile); + perror (""); + return -1; + } + + if (tsize > 0) + fprintf (out, "\nstatic char _tpc_array[][%d] = {\n\"", tsize); + else + fprintf (out, "\nstatic char _tpc_array[] = {\n\""); + + /* + * cat all source files onto output file + */ + + written = 0; + linestart = 1; + while (argnum < argc) { + if( (in= fopen( argv[argnum], "r")) == NULL) { + fprintf( stderr, "tpc: open file %s", argv[argnum]); + perror( ""); + continue; + } + + while (1) { + + c = getc (in); + + /* strip comments and leading whitespaces */ + + if (linestart == 1) { + switch (c) { + case '#': + while ((c = getc (in) != '\n') && c != EOF) {}; + break; + + case ' ': + case '\t': + case '\n': + case EOF: + break; + + default: + linestart = 0; + } + } + + /* end test */ + + if (c == EOF) + break; + + /* output read character */ + + if (linestart == 0) { + switch (c) { + case '\t': + fprintf( out, "\\t"); + written ++; + break; + + case '\n': + fprintf( out, "\\n"); + written ++; + linestart = 1; + break; + + case '\\': + case '\"': + fputc( '\\', out); + default: + fputc( c, out); + written ++; + } + } + + /* start new token if current is full */ + + if (tsize > 0) + if (written == tsize) { + fprintf (out, "\",\n\""); + written = 0; + } + } + + fclose (in); + argnum++; + } + + fprintf (out, "\"\n};\n\n"); + + /* + * declare global variable for whole string + */ + + fprintf (out, "char *"); + + /* get relative file name */ + index = strlen (outputFile) - 1; + while (outputFile[index] != '/' && index -- > 0); + index ++; + written = 0; + while ((c = outputFile[index++]) != '\0') { + if( c == '.' || c == '-') + break; + fputc (c, out); + written++; + } + + if (written == 0) { + fprintf (stderr, "tpc: can't build variable name from \"%s\".\n", + outputFile); + fclose (out); + return -1; + } + if (tsize > 0) + fprintf (out, " = _tpc_array[0];\n"); + else + fprintf (out, " = _tpc_array;\n"); + + fclose (out); + return 0; +} + diff --git a/hqp_cute/README b/hqp_cute/README new file mode 100644 index 0000000..59d149c --- /dev/null +++ b/hqp_cute/README @@ -0,0 +1,63 @@ + +README for hqp_cute, the interface for HQP 1.5 to CUTE +Ruediger Franke, 9/13/98 + +HQP is a solver for nonlinearly constrained large-scale optimization +problems. It is developed with respect to problems that have a +sufficient regular sparsity structure, e.g. discrete-time optimal +control problems. Its key features are: + + + implementation with algorithms and data structures for sparse matrices + + interior point procedure for the treatment of constraints + + Newton-type SQP procedure for the treatment of nonlinearities + +The compiled HQP library is available for several major platforms from + ftp://olymp.systemtechnik.tu-ilmenau.de/pub/tools/omuses + +This distribution contains the files needed to run HQP in the CUTE +environment. The constrained and unconstrained testing environment CUTE +is available from + ftp://joyous-gard.cc.rl.ac.uk/pub/cute. +Furthermore, you need a Tcl installation (version 8.0 or higher). See + http://www.scriptics.com + +HQP can be installed in addition to CUTE as follows: + +(1) +Four files have to be copied into an existing CUTE installation: + + $CUTEDIR +- interfaces +--------- sdhqp (call the SIF decoder) + | | + | +--------- hqp (compile and call a binary) + | + +- hqp ----------------- hqp_cute.tcl (HQP options and execution) + | + +- tools --- sources --- hqpma.f (Fortran interface code) + +Please check the installation script and execute it for copying the files + + ./copycute + +Add the new Fortran module hqpma.o to + $CUTEDIR/tools/sources/makefile, line 79 (variable OB) +and compile it, e.g. + + $CUTEDIR/instll double large + + +(2) +Install the HQP library in a directory known to your loader. +In the file + $CUTEDIR/interfaces/hqp, line 51ff, +modify compiler options, libraries, and paths according to your +installation. In particular add the C++ libraries (CCLIBS) needed by +libhqp (e.g. if libhqp was compiled using gcc and you don't use g77, +then add libgcc -- otherwise the symol __pure_virtual can't be resolved). + + +(3) +Apply HQP as described in the documentation (doc directory). + + +(4) +Send correspondence to: hqp@rz.tu-ilmenau.de diff --git a/hqp_cute/copycute b/hqp_cute/copycute new file mode 100755 index 0000000..3e3462a --- /dev/null +++ b/hqp_cute/copycute @@ -0,0 +1,25 @@ +#!/bin/sh +# installation script for HQP +# (assumes an existing CUTE installation) +# rf, 2/4/97 +# + +# check for valid environment variable CUTEDIR + +if test ! -d "$CUTEDIR"; then + echo "CUTE installation not found" + exit 1 +fi + +# create directory $CUTEDIR/hqp + +if test ! -d $CUTEDIR/hqp; then + mkdir $CUTEDIR/hqp +fi + +# copy files for HQP into the CUTE installation + +cp hqp_cute.tcl $CUTEDIR/hqp +cp hqpma.f $CUTEDIR/tools/sources +cp sdhqp $CUTEDIR/interfaces +cp hqp $CUTEDIR/interfaces diff --git a/hqp_cute/hqp b/hqp_cute/hqp new file mode 100755 index 0000000..a06ec7b --- /dev/null +++ b/hqp_cute/hqp @@ -0,0 +1,309 @@ +#!/bin/csh +# hqp: adapted from gen for application of HQP +# rf, 11/15/1995 +# last modified: 4/21/1997 +# +# Use: hqp [-n] [-h] [-s] [-k] [-o i] [-l secs] +# +# where: options -n : use the load module f if it exists +# (Default: create a new load module) +# -h : print this help and stop execution +# -s : run the single precision version +# (Default: run the double precision version) +# -k : keep the load module after use +# (Default: delete the load module) +# -o : 0 for silent mode, 1 for brief description of +# the stages executed +# (Default: -o 0) +# -l : limit the cputime used to secs seconds +# (Default: -l 99999999) + +# +# A. Conn, Nick Gould and Ph. Toint, October 28th, 1991, for CGT Productions. +# modified by I. Bongartz, May 1994. +# +# ** Correction report. +# ** Correction 1. 31/05/94: added check for installation of requested precision +# ** Correction 2. 25/07/94: added check for existence of ${GEN} object file +# ** Correction 3. 04/10/94: cleaned up setting of UTOOLS and CTOOLS +# ** Correction 4. 04/10/94: added ccifg and cscifg to CTOOLS +# ** End of Correction report. + +# +# define the package to which you wish to build an interface +# + +set GEN = hqp + +# +# basic system commands +# + +set RM = "rm -f" +set MAKE = make +set CAT = cat +set MV = mv + +# +# compiler and flags (machine dependent) +# + +set FORTRAN=f77 +set FFLAGS="" + +set HQP_LDPATH="${HOME}/lib" +set TCL_LDPATH="/usr/local/lib" +set CCLIBS="" + +set HQPLIBS="-L${HQP_LDPATH} -lhqp -L${TCL_LDPATH} -ltcl ${CCLIBS} -lm" + +# +# If there are compiled, library versions of the level-1 blas +# (basic linear algebra subprograms), set BLAS to a list of +# names of the object library suffix -lx, where the object library +# libx.a contains relevant blas. For instance if the blas are +# shared between object libraries libblas1.a and libblas2.a, +# BLAS should be set to "-lblas1 -lblas2", noting that those in +# libblas1.a will take precedence over those in libblas2.a. +# If compiled blas are unavailable, BLAS should be set to "" +# + +set BLAS="" +#set BLAS="-lblas" + +# +# directory for the main executable file +# + +set EXEC=$cwd + +# +# directory for temporary files +# + +set TMP=/tmp + +# +# name of object version of GEN (single and double precision) +# + +set SUBS= +set SUBD= + + +# +# variables for each option +# + +# +# PRECISION = 0 (single precision), = 1 (double precision) +# + +set PRECISION=1 + +# +# NEW = 0 (run existing f module), = 1 (build a new module) +# + +set NEW = 0 + +# +# KEEP = 0 (discard f load module after use), = 1 (keep it) +# + +set KEEP = 0 + +# +# OUTPUT = 0 (summary output), = 1 (detailed output from decoder) +# + +set OUTPUT=0 + +# +# LIMIT = 0 (no cputime limit) +# + +set LIMIT = 99999999 + +# +# interpret arguments +# + +@ last=$#argv +@ i=1 + +while ($i <= $last) + set opt=$argv[$i] + if("$opt" == '-n')then + set NEW=1 + else if("$opt" == '-s')then + set PRECISION=0 + else if("$opt" == '-h')then + echo ' Use: gen [-n] [-h] [-s] [-k] [-o i] [-l secs]' + echo ' ' + echo ' where: options -n : use the load module f if it exists' + echo ' (Default: create a new load module)' + echo ' -h : print this help and stop execution' + echo ' -s : run the single precision version' + echo ' (Default: run the double precision version)' + echo ' -k : keep the load module after use ' + echo ' (Default: delete the load module)' + echo ' -o : 0 for silent mode, 1 for brief description of' + echo ' the stages executed' + echo ' (Default: -o 0)' + echo ' -l : limits the cputime to secs seconds' + echo ' (Default: -l 99999999)' + exit 0 + else if("$opt" == '-k')then + set KEEP=1 + else if("$opt" == '-o')then + @ i++ + set OUTPUT=$argv[$i] + else if("$opt" == '-l')then + @ i++ + set LIMIT=$argv[$i] + else + echo 'Use: gen [-n] [-h] [-s] [-k] [-o i] [-l secs]' + exit 1 + endif + @ i++ +end + +# +# run GEN without rebuilding it +# + +if (! $NEW) then + if (! -e $EXEC/${GEN}min || ! -x $EXEC/${GEN}min) then + echo ' ' + echo "load module ${GEN}min not found/executable. Rerun with -n option" + echo ' ' + exit 3 + endif + if ($OUTPUT) then + echo ' ' + echo "running ${GEN}min on current test problem ... " + echo ' ' + endif + limit cputime $LIMIT + $EXEC/${GEN}min + +# tidy up the current directory, deleting all junk. + + if (! $KEEP) $RM $EXEC/${GEN}min + exit 0 +endif + +# +# build GEN and tools +# +# directory for object files +# + +if(! $PRECISION)then + set OBJ=$CUTEDIR/tools/objects/single + set SUBR=$SUBS +else + set OBJ=$CUTEDIR/tools/objects/double + set SUBR=$SUBD +endif + +# ** Correction 2. 25/07/94: added check for existence of ${GEN} object file + +#if (! -e $SUBR) then +# echo ' ' +# echo "${GEN} object file not in "$SUBR +# echo 'Terminating execution.' +# exit 5 +#endif + +# ** End of Correction 2. + +# ** Correction 1. 31/05/94: added check for installation of requested precision + +if (! -e $OBJ/initw.o) then + echo ' ' + echo 'Object files for tools not in '$OBJ + echo 'Terminating execution.' + exit 4 +endif + +# ** End of Correction 1. + +# if there are no library blas, include the default ones. + +if ("$BLAS" == '') then + set BLAS=$OBJ/linpac.o +endif + +# +# list of Fortran tools needed for the interface +# + +set UTOOLS = usetup,unames,ufn,ugr,uofg,udh,ugrdh,ush,ugrsh,uprod,ubandh +set CTOOLS = csetup,cnames,cfn,cgr,cofg,csgr,ccfg,cscfg,cdh,cgrdh,csh,csgrsh,cprod,ccifg,cscifg,csgreh,asmbe + +# ensure that the current test problem has been compiled. + +if ($OUTPUT) then + echo 'compiling the current test problem, if that is necessary ... ' + echo ' ' +endif + +if(-e EXTERN.f && ! -z EXTERN.f) \ +$MAKE -f $CUTEDIR/compil p >& $TMP/${GEN}f77 +if(! -e EXTERN.f || -z EXTERN.f) \ +$MAKE -f $CUTEDIR/compil pnoextern >& $TMP/${GEN}f77 + +if ($status != 0) then + $CAT $TMP/${GEN}f77 + $RM $TMP/${GEN}f77 + exit 1 +endif + +# link all the GEN and tools files together. + +if ($OUTPUT) then + $CAT $TMP/${GEN}f77 + echo ' ' + echo 'linking all the object files together ... ' + echo ' ' +endif +$RM $TMP/${GEN}f77 + +if (-e EXTERN.o && -z EXTERN.o) $RM EXTERN.o +if (-e EXTERN.f && -z EXTERN.f) $RM EXTERN.f + +if (-e EXTERN.f) then + $FORTRAN $FFLAGS -o ${GEN}min\ + ELFUNS.o GROUPS.o RANGES.o SETTYP.o EXTERN.o\ + $OBJ/${GEN}ma.o $SUBR $OBJ/{$UTOOLS}.o $OBJ/{$CTOOLS}.o\ + $OBJ/others.o $OBJ/elgrd.o $OBJ/asmbl.o\ + $OBJ/initw.o $OBJ/hsprd.o $OBJ/local.o $BLAS $HQPLIBS + if( $cwd != $EXEC ) $MV ${GEN}min $EXEC/${GEN}min +endif + +if (! -e EXTERN.f) then + $FORTRAN $FFLAGS -o ${GEN}min\ + ELFUNS.o GROUPS.o RANGES.o SETTYP.o\ + $OBJ/${GEN}ma.o $SUBR $OBJ/{$UTOOLS}.o $OBJ/{$CTOOLS}.o\ + $OBJ/others.o $OBJ/elgrd.o $OBJ/asmbl.o\ + $OBJ/initw.o $OBJ/hsprd.o $OBJ/local.o $BLAS $HQPLIBS + if( $cwd != $EXEC ) $MV ${GEN}min $EXEC/${GEN}min +endif + +# run GEN on the current test problem. + +if ($OUTPUT) then + echo ' ' + echo "running ${GEN}min on current test problem ... " + echo ' ' +endif + +limit cputime $LIMIT +time $EXEC/${GEN}min $CUTEDIR/hqp/hqp_cute.tcl + +# tidy up the current directory, deleting all junk. + +if (! $KEEP) $RM $EXEC/${GEN}min + diff --git a/hqp_cute/hqp_cute.tcl b/hqp_cute/hqp_cute.tcl new file mode 100644 index 0000000..3b37e38 --- /dev/null +++ b/hqp_cute/hqp_cute.tcl @@ -0,0 +1,161 @@ +# +# hqp_cute.tcl -- HQP (1.5) configuration and execution for CUTE problems +# +# Copyright(C) 1995-98 Ruediger Franke +# +# uncomment lines or insert statements if appropriate +# + +# +# print Meschach version on stdout +# + +#m_version + +# +# set parameters for a CUTE problem +# + +proc hqp_config {} { + + # toggle comments to apply stretching + prg_name CUTE +# prg_name CUTE_ST + + # uncomment for analytical Lagrangian Hessian +# prg_hela 1 + + # toggle comments for the SQP algorithm + sqp_solver Powell +# sqp_solver Schittkowski + + sqp_max_iters 9999 + qp_max_iters 999 + + # toggle comments for the matrix solver + qp_mat_solver RedSpBKP +# qp_mat_solver SpBKP + + if [prg_hela] { + sqp_hela Gerschgorin + } elseif {[prg_name] == "CUTE_ST"} { + sqp_hela BFGS + } else { + sqp_hela DScale + } +} + +# +# you should not need to edit anything below this line +# + +# read env(HQP_OPTIONS) +# +proc hqp_options {{stream stdout}} { + global env + + set noptions 0 + + if {![info exists env(HQP_OPTIONS)]} { + return 0 + } + + puts $stream " HQP_OPTIONS" + foreach option [split $env(HQP_OPTIONS) ","] { + if {$noptions > 0} { + puts $stream "," + } + if [regexp {(.*)\=(.*)} $option all name value] { + if {![catch {$name $value} reason]} { + puts -nonewline $stream " $name = $value" + + # adapt prg_hela automatically to sqp_hela + if {$name == "sqp_hela"} { + if {[sqp_hela] == "Gerschgorin"} { + prg_hela 1 + } else { + prg_hela 0 + } + puts -nonewline $stream ", prg_hela = [prg_hela]" + } + } else { + puts -nonewline $stream " $reason" + } + } else { + puts -nonewline $stream " $option: not understood" + } + incr noptions + } + puts $stream "\n" + + return $noptions +} + +# exit HQP +# +proc hqp_exit {reason} { + + puts "HQP [hqp_version]: $reason" + + if {[sqp_iter] > 0} { + catch prg_f f + puts "f : $f" + puts "f_evals: [prg_fbd_evals]" + prg_write_soln "$reason" + } else { + prg_write_soln -nosoln "$reason" + } + + exit 0 +} + +# +# configure HQP +# read environment variable HQP_OPTIONS +# + +hqp_config +hqp_options + +# +# solve the problem +# + +prg_setup +sqp_init + +# +# some statistics +# +catch { + puts [format " Stages/Groups: %6d / %6d" [prg_K] [prg_NEL]] +} +catch { + puts [format " HQP n/ me/ m : %6d / %6d / %6d" \ + [llength [prg_x]] [llength [sqp_y]] [llength [sqp_z]] ] +} +catch { + puts [format " Max stagesize: %6d" [sqp_hela_max_bsize]] +} +catch { + puts [format " Semibandwidth: %6d" [mat_sbw]] +} +puts "" + +#set fail [catch {hqp_solve [open /dev/null w]} reason] +set fail [catch hqp_solve reason] + +# +# write the solution and exit +# + +if {$fail} { + set source [lindex $errorInfo 3] + if {[lindex [lindex $source 0] 0] != "error"} { + hqp_exit "$reason from $source" + } else { + hqp_exit $reason + } +} + +hqp_exit "optimal solution" diff --git a/hqp_cute/hqpma.f b/hqp_cute/hqpma.f new file mode 100644 index 0000000..c2357f0 --- /dev/null +++ b/hqp_cute/hqpma.f @@ -0,0 +1,236 @@ +C +C HQP driver for problems derived from SIF files. +C +C R. Franke (based upon A. R. Conn's and Ph. Toint's cobma.f) +C 10/30/1995. +C + PROGRAM HQPMA +C + CHARACTER * 256 ARG1 +C + CALL GETARG(1, ARG1) + CALL TCLMN(ARG1) +C + END +C + SUBROUTINE CSIZE(N, M, NNZJ, NNZH) + INTEGER N, M, NNZJ, NNZH +C + INTEGER NG, NNZJMX, NNZHMX +CTOY PARAMETER ( NNZJMX = 9000, NNZHMX = 9000 ) +CMED PARAMETER ( NNZJMX = 90000, NNZHMX = 90000 ) +CBIG PARAMETER ( NNZJMX = 900000, NNZHMX = 900000 ) +C + INTEGER INPUT, IOUT +C +CSALF CHARACTER * 64 PRBDAT +CSALF PARAMETER ( INPUT = 55, IOUT = 6 ) +CUNIX CHARACTER * 64 PRBDAT +CUNIX PARAMETER ( INPUT = 55, IOUT = 6 ) +CVMS CHARACTER * 64 PRBDAT +CVMS PARAMETER ( INPUT = 55, IOUT = 6 ) +CWFC CHARACTER * 64 PRBDAT +CWFC PARAMETER ( INPUT = 55, IOUT = 6 ) +C +C Build data input file name +C +CSALF PRBDAT = 'OUTSDIF.DAT' +CUNIX PRBDAT = 'OUTSDIF.d' +CVMS PRBDAT = 'OUTSDIF.DAT' +CWFC PRBDAT = 'OUTSDIF.DAT' +C +C Open the input file. +C +CSALF OPEN ( INPUT, FILE = PRBDAT, FORM = 'FORMATTED' ) +CUNIX OPEN ( INPUT, FILE = PRBDAT, FORM = 'FORMATTED', STATUS = 'OLD' ) +CUNIX REWIND INPUT +CVMS OPEN ( INPUT, FILE = PRBDAT, FORM = 'FORMATTED', +CVMS * STATUS = 'OLD', CARRIAGECONTROL = 'LIST' ) +CWFC OPEN ( INPUT, FILE = PRBDAT, FORM = 'FORMATTED' ) +C +C Find out problem size. +C + READ( INPUT, 1000 ) N , NG + CLOSE ( INPUT ) +C + M = NG + NNZJ = NNZJMX + NNZH = NNZHMX +C +C Non-executable statements. +C + 1000 FORMAT( 10I6 ) +C +C end of CSIZE +C + END +C +C subroutine CINIT +C + SUBROUTINE CINIT(N, M, X0, BL, BU, BINF, + * EQUATN, LINEAR, V0, CL, CU, + * EFIRST, LFIRST, NVFRST) + INTEGER N, M +CS REAL X0 ( N ), BL ( N ), BU ( N ) +CS REAL V0 ( M ), CL ( M ), CU ( M ) +CS REAL BINF +CD DOUBLE PRECISION X0 ( N ), BL ( N ), BU ( N ) +CD DOUBLE PRECISION V0 ( M ), CL ( M ), CU ( M ) +CD DOUBLE PRECISION BINF + LOGICAL EQUATN( M ), LINEAR( M ) + LOGICAL EFIRST, LFIRST, NVFRST +C + INTEGER INPUT, IOUT, NMAX, MMAX +C +CSALF CHARACTER * 64 PRBDAT +CSALF PARAMETER ( INPUT = 55, IOUT = 6 ) +CUNIX CHARACTER * 64 PRBDAT +CUNIX PARAMETER ( INPUT = 55, IOUT = 6 ) +CVMS CHARACTER * 64 PRBDAT +CVMS PARAMETER ( INPUT = 55, IOUT = 6 ) +CWFC CHARACTER * 64 PRBDAT +CWFC PARAMETER ( INPUT = 55, IOUT = 6 ) +CS REAL BIGINF +CD DOUBLE PRECISION BIGINF +CS PARAMETER ( BIGINF = 9.0E+19 ) +CD PARAMETER ( BIGINF = 9.0D+19 ) +C +C Build data input file name +C +CSALF PRBDAT = 'OUTSDIF.DAT' +CUNIX PRBDAT = 'OUTSDIF.d' +CVMS PRBDAT = 'OUTSDIF.DAT' +CWFC PRBDAT = 'OUTSDIF.DAT' +C +C Open the input file. +C +CSALF OPEN ( INPUT, FILE = PRBDAT, FORM = 'FORMATTED' ) +CUNIX OPEN ( INPUT, FILE = PRBDAT, FORM = 'FORMATTED', STATUS = 'OLD' ) +CUNIX REWIND INPUT +CVMS OPEN ( INPUT, FILE = PRBDAT, FORM = 'FORMATTED', +CVMS * STATUS = 'OLD', CARRIAGECONTROL = 'LIST' ) +CWFC OPEN ( INPUT, FILE = PRBDAT, FORM = 'FORMATTED' ) +C +C Call CSETUP +C + NMAX = N + MMAX = M + CALL CSETUP(INPUT, IOUT, N, M, X0, BL, BU, NMAX, + * EQUATN, LINEAR, V0, CL, CU, MMAX, + * EFIRST, LFIRST, NVFRST) +C + CLOSE ( INPUT ) +C + BINF = BIGINF +C +C End of CINIT +C + END +C +C SUBROUTINE CWRTSN +C + SUBROUTINE CWRTSN(N, M, HEADER, F, X, V) + INTEGER N, M + CHARACTER * 60 HEADER +CS REAL F, X ( N ), V ( M ) +CD DOUBLE PRECISION F, X ( N ), V ( M ) +C + INTEGER NMAX, MMAX +CTOY PARAMETER ( NMAX = 500, MMAX = 500 ) +CMED PARAMETER ( NMAX = 5000, MMAX = 5000 ) +CBIG PARAMETER ( NMAX = 50000, MMAX = 50000 ) +C + CHARACTER * 10 PNAME + CHARACTER * 10 XNAMES ( NMAX ) + CHARACTER * 10 GNAMES ( MMAX ) +C + INTEGER OUTPUT, IOUT, I +C +CSALF CHARACTER * 64 SLNDAT +CSALF PARAMETER ( OUTPUT = 56, IOUT = 6 ) +CUNIX CHARACTER * 64 SLNDAT +CUNIX PARAMETER ( OUTPUT = 56, IOUT = 6 ) +CVMS CHARACTER * 64 SLNDAT +CVMS PARAMETER ( OUTPUT = 56, IOUT = 6 ) +CWFC CHARACTER * 64 SLNDAT +CWFC PARAMETER ( OUTPUT = 56, IOUT = 6 ) +C +C Build data output file name +C +CSALF SLNDAT = 'SOLUTION.DAT' +CUNIX SLNDAT = 'SOLUTION.d' +CVMS SLNDAT = 'SOLUTION.DAT' +CWFC SLNDAT = 'SOLUTION.DAT' +C +C Check memory size +C + IF ( N .GT. NMAX ) THEN + IF ( IOUT .GT. 0 ) THEN + WRITE( IOUT, 2100 ) 'XNAMES', 'NMAX ', N - NMAX + END IF + STOP + END IF + IF ( M .GT. MMAX ) THEN + IF ( IOUT .GT. 0 ) THEN + WRITE( IOUT, 2100 ) 'GNAMES', 'MMAX ', M - MMAX + END IF + STOP + END IF +C +C Open the output file. +C +CSALF OPEN ( OUTPUT, FILE = SLNDAT, FORM = 'FORMATTED' ) +CUNIX OPEN ( OUTPUT, FILE = SLNDAT, FORM = 'FORMATTED', +CUNIX* STATUS = 'UNKNOWN' ) +CUNIX REWIND OUTPUT +CVMS OPEN ( OUTPUT, FILE = SLNDAT, STATUS = 'UNKNOWN', +CVMS * CARRIAGECONTROL = 'LIST' ) +CWFC OPEN ( OUTPUT, FILE = SLNDAT, FORM = 'FORMATTED', +CWFC * STATUS = 'UNKNOWN') +CWFC REWIND OUTPUT +C +C Get names +C + CALL CNAMES(N, M, PNAME, XNAMES, GNAMES) +C +C Write solution +C + WRITE( OUTPUT, 2000 ) HEADER + WRITE( OUTPUT, 2010 ) PNAME + IF ( N .GT. 0 ) THEN + WRITE( OUTPUT, 2020 ) + DO 1500 I = 1, N + WRITE( OUTPUT, 2030 ) XNAMES( I ), X( I ) + 1500 CONTINUE + WRITE( OUTPUT, 2040 ) + DO 1510 I = 1, M + WRITE( OUTPUT, 2030 ) GNAMES( I ), V( I ) + 1510 CONTINUE + WRITE( OUTPUT, 2060 ) + WRITE( OUTPUT, 2070 ) F + ELSE + WRITE( OUTPUT, 2090 ) + END IF +C +C Close output file +C + CLOSE ( OUTPUT ) +C +C Non-executable statements. +C + 2000 FORMAT( '* ', A60) + 2010 FORMAT( '* problem name: ', A10) + 2020 FORMAT( /, '* variables', /) + 2030 FORMAT( ' SOLUTION ', A10, 1P, D12.5 ) + 2040 FORMAT( /, '* Lagrange multipliers', /) + 2060 FORMAT( /, '* objective function value', /) + 2070 FORMAT( ' XL SOLUTION ', 10X, 1P, D12.5 ) + 2090 FORMAT( /, '* no solution') + 2100 FORMAT( /, ' ** SUBROUTINE CWRTSN: array length ', A6, + * ' too small.', /, ' -- Miminimization abandoned.', + * /, ' -- Increase the parameter ', A6, ' by at least ', I8, + * ' and restart.' ) +C +C end of CWRTSN +C + END diff --git a/hqp_cute/sdhqp b/hqp_cute/sdhqp new file mode 100755 index 0000000..5af79a2 --- /dev/null +++ b/hqp_cute/sdhqp @@ -0,0 +1,213 @@ +#!/bin/csh +# sdGEN: script to decode a sif file and then run GEN on the output +# +# version for SUN workstations under UNIX +# +# Use: sdgen [-s] [-h] [-k] [-o j] [-l secs] probname +# +# where: options -s : run the single precision version +# (Default: run the double precision version) +# -h : print this help and stop execution +# -k : keep the load module after use +# (Default: delete the load module) +# -o : 0 for silent mode, 1 for brief description of +# the stages executed. +# (Default: -o 0) +# -l : sets a limit of secs second on the runtime +# (Default: 99999999 seconds) +# +# probname probname.SIF is the name of the file containing +# the SIF file for the problem of interest. +# + +# +# A. Conn, Nick Gould and Ph. Toint, October 28th, 1991, for CGT Productions. +# +# modified for HQP by R. Franke, 10/30/1995 +# +# ** Correction report. +# ** Correction 1. 21/09/93: set METHOD=3 (not 0 as before) +# ** Correction 2. 10/04/94: added check for installation of requested precision +# ** End of Correction report. + +# +# define the package to which you wish to make an interface +# + +set GEN = hqp + +# +# basic system commands +# + +set LS = ls +set RM = "rm -f" +set PWD = pwd +unset noclobber + +# +# directory for temporary files +# + +set TMP=/tmp + +# +# variables for each option +# + +# +# LIMIT (maximum cputime) +# + +set LIMIT=99999999 + +# +# PRECISION = 0 (single precision), = 1 (double precision) +# + +set PRECISION=1 + +# +# KEEP = 0 (discard load module after use), = 1 (keep it) +# + +set KEEP = 0 + +# +# OUTPUT = 0 (summary output), = 1 (detailed output from decoder) +# + +set OUTPUT=0 + +# +# interpret arguments +# + +set METHOD=3 + +@ last = $#argv + +if($last == 0) then + echo 'Use: sdhqp [-s] [-k] [-k] [-o j] [-l secs] probname' + exit 1 +endif + +@ i=1 + +while ($i <= $last) + set opt=$argv[$i] + if("$opt" == '-h')then + echo ' Use: sdhqp [-s] [-h] [-k] [-o j] [-l secs] probname' + echo ' ' + echo ' where: options -s : run the single precision version' + echo ' (Default: run the double precision version)' + echo ' -h : print this help and stop execution' + echo ' -k : keep the load module after use ' + echo ' (Default: delete the load module)' + echo ' -o : 0 for silent mode, 1 for brief description of' + echo ' the stages executed' + echo ' (Default: -o 0)' + echo ' -l : sets a limit of secs second on the runtime' + echo ' (Default: unlimited cputime)' + echo ' ' + echo ' probname probname.SIF is the name of the file containing' + echo ' the SIF file for the problem of interest.' + exit 0 + else if("$opt" == '-s')then + set PRECISION=0 + else if("$opt" == '-k')then + set KEEP=1 + else if("$opt" == '-o')then + @ i++ + set OUTPUT=$argv[$i] + else if("$opt" == '-l')then + @ i++ + set LIMIT=$argv[$i] + endif + @ i++ +end + +if (! -e "$argv[$last].SIF") then + echo "file $argv[$last].SIF is not known in directory $PWD." + echo "possible choices are:" + echo ' ' + $LS *.SIF + echo ' ' + exit 2 +endif + +# ** Correction 2. 10/04/94: added check for installation of requested precision + +if (! $PRECISION) then + if (! -e $CUTEDIR/sifdec_s) then + echo ' ' + echo 'Single-precision SIF decoder sifdec_s not in '$CUTEDIR + echo 'Terminating execution.' + exit 4 + endif +else + if (! -e $CUTEDIR/sifdec_d) then + echo ' ' + echo 'Double-precision SIF decoder sifdec_d not in '$CUTEDIR + echo 'Terminating execution.' + exit 4 + endif +endif + +# ** End of Correction 2. + +if ($OUTPUT) then + echo 'convert the sif file into data and routines suitable for optimizer...' + echo ' ' + echo 'problem details will be given' + echo ' ' +endif + +if (-e EXTERN.f) $RM EXTERN.f + +# call with two argument allows user to chose minimization method + +echo $argv[$last] > $TMP/sd${GEN}.input +echo $METHOD >> $TMP/sd${GEN}.input +echo $OUTPUT >> $TMP/sd${GEN}.input + +if (! $PRECISION && ! $KEEP) then + $CUTEDIR/sifdec_s < $TMP/sd${GEN}.input + if ($OUTPUT) echo ' ' + if (! -e OUTSDIF.d) then + echo ' ' + echo "error exit from decoding stage. terminating execution." + exit 3 + endif + if ($OUTPUT) echo ' ' + $CUTEDIR/interfaces/$GEN -n -s -o $OUTPUT -l $LIMIT +else if (! $PRECISION && $KEEP) then + $CUTEDIR/sifdec_s < $TMP/sd${GEN}.input + if (! -e OUTSDIF.d) then + echo ' ' + echo "error exit from decoding stage. terminating execution." + exit 3 + endif + if ($OUTPUT) echo ' ' + $CUTEDIR/interfaces/$GEN -n -s -k -o $OUTPUT -l $LIMIT +else if ($PRECISION && ! $KEEP) then + $CUTEDIR/sifdec_d < $TMP/sd${GEN}.input + if (! -e OUTSDIF.d) then + echo ' ' + echo "error exit from decoding stage. terminating execution." + exit 3 + endif + if ($OUTPUT) echo ' ' + $CUTEDIR/interfaces/$GEN -n -o $OUTPUT -l $LIMIT +else if ($PRECISION && $KEEP) then + $CUTEDIR/sifdec_d < $TMP/sd${GEN}.input + if (! -e OUTSDIF.d) then + echo ' ' + echo "error exit from decoding stage. terminating execution." + exit 3 + endif + if ($OUTPUT) echo ' ' + $CUTEDIR/interfaces/$GEN -n -k -o $OUTPUT -l $LIMIT +endif + +$RM $TMP/sd${GEN}.input diff --git a/hqp_docp/Docp_Main.C b/hqp_docp/Docp_Main.C new file mode 100644 index 0000000..3ebebd9 --- /dev/null +++ b/hqp_docp/Docp_Main.C @@ -0,0 +1,85 @@ +/* + * Docp_Main.C -- + * + * Main function for the Omuses demo collection + * + * rf, 2/10/98 + * + * rf, 11/10/00 + * updated for new interface of Hqp 1.7 + */ + +#include +#include +#include +#include + +#include "Prg_Di.h" + +/** Handle used for calls to Hqp Docp instance */ +Hqp_Docp_handle theHqp_Docp_handle; + +/** + * Simple main function. + * First Hqp is initialized using the Docp interface. + * Afterwards the solver is executed via the If interface. + */ +int main(int, char *[]) +{ + // Assert that Hqp uses same data representation as this application + // (might be different if different C++ compilers are used) + assert(If_SizeOfInt() == sizeof(int)); + assert(If_SizeOfReal() == sizeof(Real)); + + // Create Docp specification from problem as declared in file Prg_Di.h + Hqp_Docp_spec spec = Prg_Di_spec(); + + // Create Hqp_Docp and register callback functions + theHqp_Docp_handle = Hqp_Docp_create(spec, NULL); + + // Configure solver + printf("Configure solver\n"); + double eps = 1e-5; + + // write sqp_eps + if (If_SetReal("sqp_eps", eps) != IF_OK) + printf("Can't write sqp_eps: %s\n", If_ResultString()); + + // test read sqp_eps back + // (from now on error tests are omitted for If-calls + // in order to improve readability) + eps = 0.0; + If_GetReal("sqp_eps", eps); + printf(" set sqp_eps to: %g\n", eps); + + printf("\nSolve problem\n"); + + // Setup and initialize problem + If_Eval("prg_setup"); // setup problem + If_Eval("prg_simulate"); // perform initial value simulation + If_Eval("sqp_init"); // initialize SQP solver + + // Solve problem + if (If_Eval("hqp_solve") != IF_OK) { + printf("Failed : %s\n", If_ResultString()); + } + else { + printf("Optimal solution found\n"); + } + + // Write solution statistics + double objective; + int iters, steps; + If_GetReal("prg_f", objective); + If_GetInt("sqp_iter", iters); + If_GetInt("prg_fbd_evals", steps); + printf("Objective : %g\n", objective); + printf("Iters : %d\n", iters); + printf("Line steps: %d\n", steps); + + // Destroy Hqp_Docp + Hqp_Docp_destroy(theHqp_Docp_handle); + + return 0; +} + diff --git a/hqp_docp/Makefile.in b/hqp_docp/Makefile.in new file mode 100644 index 0000000..63c9662 --- /dev/null +++ b/hqp_docp/Makefile.in @@ -0,0 +1,85 @@ +# +# Makefile for the package Odc +# + +include ../makedirs + +O = @OBJ_SUFFIX@ + +.SUFFIXES: .c .C $O @LIB_SUFFIX@ + +# +# machine dependencies +# + +# +# additional objects to create an executable +# +MACH_OBJS = @TCL_LIBS@ + +LFLAG = @LFLAG@ +# +# flag to add a path for the run-time loader +# (e.g. -R -Wl,-rpath, -Wl,+b,) +# -- or just use $LFLAG resulting in no run-path +# and make libtcl, libhqp, and libomu known through +# the environment variable LD_LIBRARY_PATH -- +RFLAG = @RFLAG@ + +# +# paths +# +OMU_PREFIX = @prefix@ + +OMU_INCDIR = -I../meschach -I../iftcl -I../hqp \ + -I${OMU_PREFIX}/include/omuses + +OMU_LIBDIR = $(LFLAG)../lib $(RFLAG)../lib \ + $(LFLAG)${OMU_PREFIX}/lib $(RFLAG)${OMU_PREFIX}/lib + +# +# compiler and flags +# + +CXX = @CXX@ +CC = @CC@ + +CFLAGS = @GFLAG@ @WFLAG@ -DDEBUG \ + $(OMU_INCDIR) $(TCL_INCDIR) + +LDFLAGS = $(OMU_LIBDIR) $(TCL_LIBDIR) + +# +# machine independent part +# + +GMALLOC_O = @GMALLOC_O@ + +SRCS = Docp_Main.C \ + Prg_Di.C + +OBJS = $(SRCS:.C=$O) $(GMALLOC_O) + +RESULT = docp + +all: $(OBJS) Makefile + $(CXX) -o $(RESULT) $(OBJS) \ + @LDFLAGS_START@ $(LDFLAGS) @LDLIB_PREFIX@hqp@LDLIB_SUFFIX@ $(MACH_OBJS) + +gmalloc $(GMALLOC_O): $(GMALLOC_O:$O=.c) + PWD=`pwd`; cd `dirname $(GMALLOC_O)`; \ + make `basename $(GMALLOC_O)`; cd $(PWD) + +.C$O: + $(CXX) -c @CXXFLAGS@ $(CFLAGS) $< + +.c$O: + $(CC) -c $(CFLAGS) $< + +clean: + rm -f $(RESULT)@EXE_SUFFIX@ *.o *.obj *~ *core + +depend: + makedepend -- $(CFLAGS) -- $(SRCS) + +# DO NOT DELETE THIS LINE -- make depend depends on it. diff --git a/hqp_docp/Prg_Di.C b/hqp_docp/Prg_Di.C new file mode 100644 index 0000000..729e870 --- /dev/null +++ b/hqp_docp/Prg_Di.C @@ -0,0 +1,176 @@ +/* + * Prg_Di.C -- class definition + * + * rf, 1/29/95 + * + * rf, 2/10/98 + * - updated for HQP 1.3 + * + * rf, 7/11/00 + * - updated for HQP 1.7 + */ + +#include + +extern Hqp_Docp_handle theHqp_Docp_handle; + +/** Number of stages */ +static int _kmax = 60; + +/** Additional sampling for path constraint? */ +static bool _cns = true; + +//-------------------------------------------------------------------------- +static void setup_horizon(void *clientdata, int &k0, int &kf) +{ + k0 = 0; + kf = _kmax; +} + +//-------------------------------------------------------------------------- +static void setup_vars(void *clientdata, int k, + VECP x, VECP xmin, VECP xmax, + VECP u, VECP umin, VECP umax, + VECP c, VECP cmin, VECP cmax) +{ + // dimension variables + Hqp_Docp_alloc_vars(theHqp_Docp_handle, x, xmin, xmax, 2); + if (k < _kmax) + Hqp_Docp_alloc_vars(theHqp_Docp_handle, u, umin, umax, 1); + + // initial values + if (k == 0) { + x[0] = 1.0; + x[1] = 0.0; + } + if (k < _kmax) + u[0] = -2.0; + + // initial state constraints + if (k == 0) { + xmin[0] = xmax[0] = x[0]; + xmin[1] = xmax[1] = x[1]; + } + // path constraint + else if (k < _kmax) { + xmax[1] = 0.01; + } + // final state constraints + else { + xmin[0] = xmax[0] = -1.0; + xmin[1] = xmax[1] = 0.0; + } + + // optional additional treatment for path constraint + if (_cns) { + if (k < _kmax) { + Hqp_Docp_alloc_vars(theHqp_Docp_handle, c, cmin, cmax, 1); + cmax[0] = 0.01; + } + } +} + +//-------------------------------------------------------------------------- +static void update_vals(void *clientdata, int k, + const VECP x, const VECP u, + VECP f, Real &f0, VECP c) +{ + double dt = 1.0/_kmax; + + // update constraints and objective for given x and u + if (k < _kmax) { + f[0] = x[0] + u[0]*dt; + f[1] = x[0]*dt + x[1] + u[0]*0.5*dt*dt; + + f0 = u[0] * u[0] * dt; + + if (_cns) { + c[0] = x[1] + 0.5*dt*x[0]; + } + } + else + f0 = 0.0; +} + +//-------------------------------------------------------------------------- +static void setup_struct(void *clientdata, int k, + VECP f0x, VECP f0u, int &f0_lin, + MATP fx, MATP fu, IVECP f_lin, + MATP cx, MATP cu, IVECP c_lin, + MATP Lxx, MATP Luu, MATP Lxu) +{ + // Setup sparse structure of problem and initialize linear constraints. + // Don't setup Hessian blocks in Lxx, Luu, Lxu, + // i.e. they are assumed dense. + + double dt = 1.0/_kmax; + + f0x[0] = 0.0; + f0x[1] = 0.0; + if (k == _kmax) { + f0_lin = 1; + } + + if (k < _kmax) { + fx[0][0] = 1.0; + fx[0][1] = 0.0; + fx[1][0] = dt; + fx[1][1] = 1.0; + + fu[0][0] = dt; + fu[1][0] = 0.5*dt*dt; + + f_lin[0] = f_lin[1] = 1; + + if (_cns) { + cx[0][0] = 0.5*dt; + cx[0][1] = 1.0; + cu[0][0] = 0.0; + c_lin[0] = 1; + } + } +} + +//-------------------------------------------------------------------------- +static void update_stage(void *clientdata, int k, + const VECP x, const VECP u, + VECP f, Real &f0, VECP c, + MATP fx, MATP fu, + VECP f0x, VECP f0u, + MATP cx, MATP cu, + const VECP rf, const VECP rc, + MATP Lxx, MATP Luu, MATP Lxu) +{ + // update values + update_vals(clientdata, k, x, u, f, f0, c); + + // Update derivatives of non-linear functions. + // Don't update Hessian blocks, as this is done by solver. + + double dt = 1.0/_kmax; + + if (k < _kmax) { + f0u[0] = 2.0*u[0]*dt; + } +} + +//-------------------------------------------------------------------------- +Hqp_Docp_spec Prg_Di_spec() +{ + // register own callback functions to Docp interface + Hqp_Docp_spec spec; + + // obligatory functions + spec.setup_horizon = setup_horizon; + spec.setup_vars = setup_vars; + spec.update_vals = update_vals; + + // optional callback routines + spec.setup_struct = setup_struct; + spec.update_stage = update_stage; + + return spec; +} + + +//========================================================================== diff --git a/hqp_docp/Prg_Di.h b/hqp_docp/Prg_Di.h new file mode 100644 index 0000000..f3694eb --- /dev/null +++ b/hqp_docp/Prg_Di.h @@ -0,0 +1,25 @@ +/* + * Prg_Di.h -- + * - double integrator with state constraint + * + * rf, 1/29/95 + * + * rf, 2/10/98 + * - updated for HQP 1.3 + * + * rf, 7/11/00 + * - updated for HQP 1.7 + */ + +#ifndef Prg_Di_H +#define Prg_Di_H + +#include + +/** Function that returns problem specification */ +Hqp_Docp_spec Prg_Di_spec(); + + +#endif + + diff --git a/hqp_docp/README b/hqp_docp/README new file mode 100644 index 0000000..5149ff4 --- /dev/null +++ b/hqp_docp/README @@ -0,0 +1,28 @@ + +README for hqp_docp, an example for applying HQP 1.5 +directly to multistage problems +Ruediger Franke, 9/13/98 + +The front-end Omuses is intended to provide as much comfort as +possible when specifying multistage problems. However, the cost is +computational time. The DOCP interface, which is accessed by Omuses, +can also be used directly. Following things have to be specified +manually: + -- derivatives + -- solutions of differential equations over stages + -- sample periods within stages + +Try out hqp_docp as follows: + +(1) +Invoke + ./make +to create the executable 'docp'. + +(2) +Invoke + ./run Di +to run a simple example (constrained double integrator). + +(4) +Send correspondence to: hqp@rz.tu-ilmenau.de diff --git a/hqp_docp/run b/hqp_docp/run new file mode 100755 index 0000000..d49ad01 --- /dev/null +++ b/hqp_docp/run @@ -0,0 +1,71 @@ +#!./docp +# +# rf, 2/10/98 +# + +## say Hello + +set version "HQP [hqp_version]" +if [catch { + label .l \ + -text $version + button .b \ + -text Exit \ + -command {hqp_exit user} + pack .l .b + update +}] { + puts $version +} + +## use the first runtime argument as problem name +## run a problem specific script file if provided +## else run without configurations + +set pname [lindex $argv 0] +set fname [string tolower $pname].tcl +if [file exists $fname] { + source $fname +} else { + +if [catch {prg_name $pname} result] { + puts stderr "Usage: run " + puts stderr $result + exit +} + +## configure the problem and the solver + +## optimization stopping limit +#sqp_eps 1e-6 + +## run the solver + +# setup the problem +prg_setup + +# perform an initial-value simulation +# (this is only needed to initialize additional states variables) +prg_simulate + +# initialize the SQP solver +sqp_init + +# evaluate the Tcl procedure hqp_solve and catch errors +catch hqp_solve result + +## print the results and exit + +puts "Result : $result" +puts "Objective: [prg_f]" +puts "Obj-evals: [prg_fbd_evals]" +set x [prg_x] +set n [llength $x] +if {$n <= 100} { + puts "Variables:" + for {set i 0} {$i < $n} {incr i} { + puts [lrange $x $i [incr i 7]] + } + exit +} +} diff --git a/iftcl/If.C b/iftcl/If.C new file mode 100644 index 0000000..797e35d --- /dev/null +++ b/iftcl/If.C @@ -0,0 +1,153 @@ +/* + * If.C: implementation of public interface functions + * + * rf, 11/09/00 + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include "If.h" +#include "If_Element.h" + +#include + +//----------------------------------------------------------------------- +extern "C" int If_SizeOfInt() +{ + return sizeof(int); +} + +//----------------------------------------------------------------------- +extern "C" int If_SetInt(const char *name, int val) +{ +#if 0 + // unfortunately Tcl_EvalObjv was not available under Tcl 8.0 + Tcl_Obj *objv[2]; + + objv[0] = Tcl_NewStringObj((char *)name, -1); + objv[1] = Tcl_NewIntObj(val); + + int retcode; + retcode = Tcl_EvalObjv(theInterp, 2, objv, 0); + + Tcl_DecrRefCount(objv[0]); + Tcl_DecrRefCount(objv[1]); + + if (retcode != TCL_OK) + return IF_ERROR; +#else + char valstr[50]; + sprintf(valstr, "%d", val); + if (Tcl_VarEval(theInterp, (char *)name, " ", valstr, NULL) != TCL_OK) + return IF_ERROR; +#endif + + Tcl_ResetResult(theInterp); // reset result as val was accepted + return IF_OK; +} + +//----------------------------------------------------------------------- +extern "C" int If_GetInt(const char *name, int &val) +{ + if (Tcl_Eval(theInterp, (char *)name) != TCL_OK) + return IF_ERROR; + + if (Tcl_GetIntFromObj(theInterp, Tcl_GetObjResult(theInterp), &val) + != TCL_OK) + return IF_ERROR; + + Tcl_ResetResult(theInterp); // reset result as val is already returned + return IF_OK; +} + +//----------------------------------------------------------------------- +extern "C" int If_SizeOfReal() +{ + return sizeof(Real); +} + +//----------------------------------------------------------------------- +extern "C" int If_SetReal(const char *name, Real val) +{ +#if 0 + // unfortunately Tcl_EvalObjv was not available under Tcl 8.0 + Tcl_Obj *objv[2]; + + objv[0] = Tcl_NewStringObj((char *)name, -1); + objv[1] = Tcl_NewDoubleObj(val); + + int retcode; + retcode = Tcl_EvalObjv(theInterp, 2, objv, 0); + + Tcl_DecrRefCount(objv[0]); + Tcl_DecrRefCount(objv[1]); + + if (retcode != TCL_OK) + return IF_ERROR; +#else + char valstr[50]; + sprintf(valstr, "%g", val); + if (Tcl_VarEval(theInterp, (char *)name, " ", valstr, NULL) != TCL_OK) + return IF_ERROR; +#endif + + Tcl_ResetResult(theInterp); // reset result as val was accepted + return IF_OK; +} + +//----------------------------------------------------------------------- +extern "C" int If_GetReal(const char *name, Real &val) +{ + if (Tcl_Eval(theInterp, (char *)name) != TCL_OK) + return IF_ERROR; + + if (Tcl_GetDoubleFromObj(theInterp, Tcl_GetObjResult(theInterp), &val) + != TCL_OK) + return IF_ERROR; + + Tcl_ResetResult(theInterp); // reset result as val is already returned + return IF_OK; +} + +//----------------------------------------------------------------------- +extern "C" int If_Eval(const char *command) +{ + if (Tcl_Eval(theInterp, (char *)command) != TCL_OK) + return IF_ERROR; + + return IF_OK; +} + +//----------------------------------------------------------------------- +extern "C" int If_EvalStringArg(const char *command, const char *arg) +{ + if (Tcl_VarEval(theInterp, (char *)command, " ", arg, NULL) != TCL_OK) + return IF_ERROR; + + return IF_OK; +} + +//----------------------------------------------------------------------- +extern "C" const char *If_ResultString() +{ + return Tcl_GetStringResult(theInterp); +} + +//======================================================================= diff --git a/iftcl/If.h b/iftcl/If.h new file mode 100644 index 0000000..f0e972e --- /dev/null +++ b/iftcl/If.h @@ -0,0 +1,74 @@ +/* + * If.h: public declarations of the interface library + * + * rf, 10/4/95 + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_H +#define If_H + +#include "Meschach.h" + +/** define IF_API when compiling a Dynamic Link Library (DLL) */ +#ifndef IF_API +#define IF_API +#endif + +/** Return code for successful calculation. */ +#define IF_OK 0 + +/** Return code for failed calculation. */ +#define IF_ERROR 1 + + +extern "C" { + /** Return size of Int. */ + IF_API int If_SizeOfInt(); + + /** Set an Int value. */ + IF_API int If_SetInt(const char *name, int val); + + /** Get an Int value. */ + IF_API int If_GetInt(const char *name, int &val); + + /** Return size of Real. */ + IF_API int If_SizeOfReal(); + + /** Set a Real value. */ + IF_API int If_SetReal(const char *name, Real val); + + /** Get a Real value. */ + IF_API int If_GetReal(const char *name, Real &val); + + /** Evaluate a command. */ + IF_API int If_Eval(const char *command); + + /** Evaluate a command with string argument */ + IF_API int If_EvalStringArg(const char *command, const char *arg); + + /** Return the result string produced by the last If function call. + After a failed calculation, the corresponding error message + is returned. */ + IF_API const char *If_ResultString(); +} + +#endif diff --git a/iftcl/If_Bool.C b/iftcl/If_Bool.C new file mode 100644 index 0000000..57052b7 --- /dev/null +++ b/iftcl/If_Bool.C @@ -0,0 +1,82 @@ +/* + * If_Bool.C -- class definiton + * + * rf, 1/17/97 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#include "If_Bool.h" + + +//-------------------------------------------------------------------------- +If_Bool::If_Bool(char *ifName, If_Bool_t *varPtr, If_BoolWriteIf *callback) +:If_Variable(ifName) +{ + _varPtr = varPtr; + _callback = callback; +} + +//-------------------------------------------------------------------------- +If_Bool::~If_Bool() +{ + delete _callback; +} + +//-------------------------------------------------------------------------- +int If_Bool::put(Tcl_Obj *CONST objPtr) +{ + int value; + + // parse the new value + //-------------------- + if (Tcl_GetBooleanFromObj(theInterp, objPtr, &value) != TCL_OK) + return TCL_ERROR; + + // use the new value + //------------------ + if (_callback) { + if (_callback->write((If_Bool_t)value) != IF_OK) { + Tcl_AppendResult(theInterp, "writing of ", _ifName, " rejected", NULL); + return TCL_ERROR; + } + } + else + *_varPtr = (If_Bool_t)value; + + return TCL_OK; +} + +//-------------------------------------------------------------------------- +int If_Bool::get() +{ + int value = (int)*_varPtr; + Tcl_Obj *objPtr = Tcl_NewBooleanObj(*_varPtr); + + Tcl_SetObjResult(theInterp, objPtr); + + return TCL_OK; +} + + +//========================================================================== diff --git a/iftcl/If_Bool.h b/iftcl/If_Bool.h new file mode 100644 index 0000000..b8b4bd8 --- /dev/null +++ b/iftcl/If_Bool.h @@ -0,0 +1,88 @@ +/* + * If_Bool.h -- + * - an If_Variable for type Bool + * + * rf, 1/19/97 + * + * rf, 8/13/98 + * - use typed Tcl 8 objects instead of strings + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_Bool_H +#define If_Bool_H + +#include "If_Variable.h" + +typedef bool If_Bool_t; + +// callback for write-access +//-------------------------- +class If_BoolWriteIf { + + public: + virtual ~If_BoolWriteIf() {} + virtual int write(If_Bool_t newVal)=0; +}; + +template +class If_BoolWriteCB: public If_BoolWriteIf { + + protected: + X *_object; + int (X::*_write)(If_Bool_t); + + public: + If_BoolWriteCB(int (X::*n_write)(If_Bool_t), X *n_object) + { + assert(n_write != NULL && n_object != NULL); + _write = n_write; + _object = n_object; + } + int write(If_Bool_t newVal) + { + return (_object->*_write)(newVal); + } +}; + + +// class declaration +//------------------ +class If_Bool: public If_Variable { + + protected: + + If_Bool_t *_varPtr; + If_BoolWriteIf *_callback; + + // define abstract methods of If_Variable + //--------------------------------------- + int put(Tcl_Obj *CONST objPtr); + int get(); + + public: + + If_Bool(char *ifName, If_Bool_t *varPtr, If_BoolWriteIf *callback=NULL); + ~If_Bool(); +}; + + +#endif diff --git a/iftcl/If_Class.C b/iftcl/If_Class.C new file mode 100644 index 0000000..c13897a --- /dev/null +++ b/iftcl/If_Class.C @@ -0,0 +1,67 @@ +/* + * If_Class.C -- + * basic definitions for managing interface modules + * + * rf, 10/5/95 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#include "If_Class.h" + +// +// If_idList +// + +If_idList::If_idList() +{ + _cand_names_size = 100; + _cand_names = (char *)malloc(_cand_names_size); + sprintf(_cand_names, "Candidates: "); +} + +If_idList::~If_idList() +{ + free(_cand_names); +} + +void If_idList::append(If_idListElement *element) +{ + size_t len, add; + + // store the element's name + len = strlen(_cand_names) + 1; // one more for terminating null + add = strlen(element->if_id()) + 2; // two more for seperator ", " + if (len + add > _cand_names_size) { + _cand_names_size += (add > 100)? add: 100; + _cand_names = (char *)realloc(_cand_names, _cand_names_size); + } + if (top() != NULL) + sprintf(_cand_names + len - 1, ", %s", (const char *)element->if_id()); + else + sprintf(_cand_names + len - 1, "%s", (const char *)element->if_id()); + + // append the element + If_List::append(element); +} + diff --git a/iftcl/If_Class.h b/iftcl/If_Class.h new file mode 100644 index 0000000..75c4f43 --- /dev/null +++ b/iftcl/If_Class.h @@ -0,0 +1,158 @@ +/* + * If_Class.h -- + * basic definitions for managing interface modules + * + * rf, 10/5/95 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_Class_H +#define If_Class_H + +#include "If_id.h" +#include "If_List.h" +#include "If_ListElement.h" + +// +// macros for defining interface modules +// +// IF_BASE_DECLARE: usage in the header file of a base class +// IF_BASE_DEFINE: usage in the implementation file of a base class +// IF_CLASS_DEFINE: usage in the implementation file of a derived class +// IF_CLASS_ALLOC: manually allocate on machines without static constructors +// + +#define IF_BASE_DECLARE(base) class base; \ + extern If_ClassList *theIf_ClassList_##base; + +#define IF_BASE_DEFINE(base) \ + If_ClassList *theIf_ClassList_##base = NULL; + +#ifndef IF_CLASS_STATIC +#define IF_CLASS_DEFINE(id, type, base) \ + static If_Class if_class_##type(id, theIf_ClassList_##base); +#else +#define IF_CLASS_DEFINE(id, type, base) +#define IF_CLASS_ALLOC(id, type, base) \ + new If_Class(id, theIf_ClassList_##base); +#endif + +// +// If_List +// (see If_List.h) +// | +// If_idList +// manage a string with If_id's of all elements of the list +// | +// If_ClassList +// one list should be defined for each base class of similar modules +// + +class If_idListElement; + +class If_idList: public If_List { + protected: + char *_cand_names; + size_t _cand_names_size; + + public: + If_idList(); + ~If_idList(); + + void append(If_idListElement *); + const char *cand_names() {return _cand_names;} +}; + +template +class If_BaseClass; + +template +class If_ClassList: public If_idList { + public: + BASE *createObject(const If_id id) + { + If_BaseClass *el; + + el = (If_BaseClass *)top(); + while(el && el->if_id() != id) + el = (If_BaseClass *)prev(el); + + if (!el) + return NULL; + + return el->createObject(); + } +}; + +// +// If_ListElement +// (see If_ListElement.h) +// | +// If_idListElement +// - store an If_id for the element +// +// | +// If_BaseClass +// - constructor creates the list and appends elements +// - declare abstract method for object creation of type BASE +// | +// If_Class +// - define abstract method for object creation, using type TYPE +// + +class If_idListElement: public If_ListElement { + protected: + If_id _id; + public: + If_idListElement(If_id id) + : _id(id) {} + If_id if_id() + { + return _id; + } +}; + +template +class If_BaseClass: public If_idListElement { + public: + If_BaseClass(If_id id, If_ClassList*& list) + : If_idListElement(id) + { + if (!list) + list = new If_ClassList; + list->append(this); + } + virtual BASE *createObject() = 0; +}; + +template +class If_Class: public If_BaseClass { + public: + If_Class(If_id id, If_ClassList*& list) + : If_BaseClass(id, list) {}; + BASE *createObject() + { + return new TYPE; + } +}; + + +#endif diff --git a/iftcl/If_Command.C b/iftcl/If_Command.C new file mode 100644 index 0000000..4596d34 --- /dev/null +++ b/iftcl/If_Command.C @@ -0,0 +1,49 @@ +/* + * If_Command.C -- class definition + * + * rf, 7/20/94 + * + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include "If_Command.h" + + +//-------------------------------------------------------------------------- +If_Command::If_Command(char *ifName) +:If_Element(ifName) +{ + Tcl_CreateCommand(theInterp, _ifName, &tclCmd, (ClientData)this, NULL); +} + +//-------------------------------------------------------------------------- +If_Command::~If_Command() +{ + Tcl_DeleteCommand(theInterp, _ifName); +} + + +//-------------------------------------------------------------------------- +int If_Command::tclCmd(ClientData cld, Tcl_Interp *interp, + int argc, char *argv[]) +{ + return ((If_Command *)cld)->invoke(argc, argv, &interp->result); +} diff --git a/iftcl/If_Command.h b/iftcl/If_Command.h new file mode 100644 index 0000000..edd7005 --- /dev/null +++ b/iftcl/If_Command.h @@ -0,0 +1,58 @@ +/* + * If_Command.h + * - abstract base class for interface commands + * + * rf, 7/20/94 + * + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_Command_H +#define If_Command_H + +#include "If_Element.h" + +#define IF_CMD_ARGS int, char *[], char ** +#define IF_DEF_ARGS int argc=0, char *argv[]=NULL, char **result=NULL + + +//----------------------------------- +class If_Command: public If_Element { + + protected: + + If_Command(char *ifName); + + // interface to Tcl + //----------------- + static int tclCmd(ClientData, Tcl_Interp *, int argc, char *argv[]); + + // interface to derived classes + //----------------------------- + virtual int invoke(int argc, char *argv[], char **result)=0; + + public: + + ~If_Command(); +}; + + +#endif diff --git a/iftcl/If_Element.C b/iftcl/If_Element.C new file mode 100644 index 0000000..43a724f --- /dev/null +++ b/iftcl/If_Element.C @@ -0,0 +1,48 @@ +/* + * If_Element.C -- class definition + * + * rf, 6/22/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#include "If_ListElement.h" +#include "If_Element.h" + +//-------------------------------------------------------------------------- +Tcl_Interp *theInterp = NULL; + +//-------------------------------------------------------------------------- +If_Element::If_Element(const char *ifName) +{ + _ifName = strdup(ifName); +} + +//-------------------------------------------------------------------------- +If_Element::~If_Element() +{ + free(_ifName); +} + + +//========================================================================== diff --git a/iftcl/If_Element.h b/iftcl/If_Element.h new file mode 100644 index 0000000..a34c44b --- /dev/null +++ b/iftcl/If_Element.h @@ -0,0 +1,62 @@ +/* + * If_Element.h -- + * - abstract base class for interface elements to Tcl + * (e.g. variables, commands) + * - provides: + * + a textual name for every interface element + * + a static Tcl_Interp for all elements + * + * rf, 22/6/94, rev. 1.0 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_Element_H +#define If_Element_H + +extern "C" { +#ifdef VARARGS +#undef VARARGS +#endif +#include +#undef VARARGS +} + +#include "If.h" +#include "If_ListElement.h" + + +// global Tcl interpreter, that must be initialized by an application +//------------------------------------------------------------------- +extern Tcl_Interp *theInterp; + +//----------------------------------------------------- +class If_Element: public If_ListElement { + + protected: + char *_ifName; + + public: + If_Element(const char *ifName); + virtual ~If_Element(); +}; + + +#endif diff --git a/iftcl/If_Float.C b/iftcl/If_Float.C new file mode 100644 index 0000000..5b6a82b --- /dev/null +++ b/iftcl/If_Float.C @@ -0,0 +1,80 @@ +/* + * If_Float.C -- class definiton + * + * rf, 1/25/97 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include + +#include "If_Float.h" + +//-------------------------------------------------------------------------- +If_Float::If_Float(char *ifName, If_Float_t *varPtr, + If_FloatWriteIf *callback) +:If_Variable(ifName) +{ + _varPtr = varPtr; + _callback = callback; +} + +//-------------------------------------------------------------------------- +If_Float::~If_Float() +{ + delete _callback; +} + +//-------------------------------------------------------------------------- +int If_Float::put(Tcl_Obj *CONST objPtr) +{ + If_Float_t value; + + // parse the new value + //-------------------- + if (Tcl_GetDoubleFromObj(theInterp, objPtr, &value) != TCL_OK) + return TCL_ERROR; + + // use the new value + //------------------ + if (_callback) { + if (_callback->write(value) != IF_OK) { + Tcl_AppendResult(theInterp, "writing of ", _ifName, " rejected", NULL); + return TCL_ERROR; + } + } + else + *_varPtr = value; + + return TCL_OK; +} + +//-------------------------------------------------------------------------- +int If_Float::get() +{ + Tcl_Obj *objPtr = Tcl_NewDoubleObj(*_varPtr); + + Tcl_SetObjResult(theInterp, objPtr); + + return TCL_OK; +} + + +//========================================================================== diff --git a/iftcl/If_Float.h b/iftcl/If_Float.h new file mode 100644 index 0000000..a7a499a --- /dev/null +++ b/iftcl/If_Float.h @@ -0,0 +1,89 @@ +/* + * If_Float.h -- + * - an If_Variable for floats (currently supported: double) + * + * rf, 2/7/97 + * + * rf, 8/13/98 + * - use typed Tcl 8 objects instead of strings + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_Float_H +#define If_Float_H + +#include "If_Variable.h" + +typedef double If_Float_t; + +// callback for write-access +//-------------------------- +class If_FloatWriteIf { + + public: + virtual ~If_FloatWriteIf() {} + virtual int write(If_Float_t newVal)=0; +}; + +template +class If_FloatWriteCB: public If_FloatWriteIf { + + protected: + X *_object; + int (X::*_write)(If_Float_t); + + public: + If_FloatWriteCB(int (X::*n_write)(If_Float_t), X *n_object) + { + assert(n_write != NULL && n_object != NULL); + _write = n_write; + _object = n_object; + } + int write(If_Float_t newVal) + { + return (_object->*_write)(newVal); + } +}; + + +// class declaration +//------------------ +class If_Float: public If_Variable { + + protected: + + If_Float_t *_varPtr; + If_FloatWriteIf *_callback; + + // define abstract methods of If_Variable + //--------------------------------------- + int put(Tcl_Obj *CONST objPtr); + int get(); + + public: + + If_Float(char *ifName, If_Float_t *varPtr, + If_FloatWriteIf *callback=NULL); + ~If_Float(); +}; + + +#endif diff --git a/iftcl/If_FloatMat.C b/iftcl/If_FloatMat.C new file mode 100644 index 0000000..79b43b3 --- /dev/null +++ b/iftcl/If_FloatMat.C @@ -0,0 +1,157 @@ +/* + * If_FloatMat.C -- class definition + * + * rf, 8/19/94 + * + * rf, 2/2/97 + * -- check NULL + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include +#include + +#include "If_FloatMat.h" + +//-------------------------------------------------------------------------- +If_FloatMat::If_FloatMat(char *ifName, MAT **varPtr, + If_FloatMatWriteIf *callback) +:If_Variable(ifName) +{ + _varPtr = varPtr; + _callback = callback; +} + +//-------------------------------------------------------------------------- +If_FloatMat::If_FloatMat(char *ifName, MATP *varPtr, + If_FloatMatWriteIf *callback) +:If_Variable(ifName) +{ + _varPtr = (MAT **)varPtr; + _callback = callback; +} + +//-------------------------------------------------------------------------- +If_FloatMat::~If_FloatMat() +{ + delete _callback; +} + +//-------------------------------------------------------------------------- +int If_FloatMat::put(Tcl_Obj *CONST objPtr) +{ + int i, j; + int nrows = 0, ncols = 0; + int dummy; + Tcl_Obj **rows, **cols; + double element; + + // split up the matrix into it's rows + //----------------------------------- + if (Tcl_ListObjGetElements(theInterp, objPtr, &nrows, &rows) != TCL_OK) + return TCL_ERROR; + + // split up the first row -- to get the number of cols + //---------------------------------------------------- + if (nrows > 0) + if (Tcl_ListObjGetElements(theInterp, rows[0], &ncols, &cols) != TCL_OK) { + return TCL_ERROR; + } + + // check dimension + //---------------- + if (*_varPtr == MNULL + || nrows != (int)(*_varPtr)->m || ncols != (int)(*_varPtr)->n) { + Tcl_AppendResult(theInterp, "wrong dimension", NULL); + return TCL_ERROR; + } + + // create and fill a new matrix + //----------------------------- + MAT *newMat = m_get(nrows, ncols); + + for (i = 0; i < nrows; i++) { + if (i > 0) { + if (Tcl_ListObjGetElements(theInterp, rows[i], &dummy, &cols) != TCL_OK) { + m_free(newMat); + return TCL_ERROR; + } + if (dummy != ncols) { + Tcl_AppendResult(theInterp, "Different sizes of rows!", NULL); + m_free(newMat); + return TCL_ERROR; + } + } + for ( j = 0; j < ncols; j++) { + + // parse the new value + //-------------------- + if (Tcl_GetDoubleFromObj(theInterp, cols[j], &element) != TCL_OK) { + m_free(newMat); + return TCL_ERROR; + } + newMat->me[i][j] = element; + } + } + + // use the new matrix + //------------------- + if (_callback) { + if (_callback->write(newMat) != IF_OK) { + Tcl_AppendResult(theInterp, "writing of ", _ifName, " rejected", NULL); + m_free(newMat); + return TCL_ERROR; + } + } + else + *_varPtr = m_copy(newMat, *_varPtr); + + m_free(newMat); + + return TCL_OK; +} + +//-------------------------------------------------------------------------- +int If_FloatMat::get() +{ + MAT *mat = *_varPtr; + int i, iend = mat? mat->m: 0; + int j, jend = mat? mat->n: 0; + Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL); + Tcl_Obj *rowPtr, *objPtr; + + for (i = 0; i < iend; i++) { + rowPtr = Tcl_NewListObj(0, NULL); + for (j = 0; j < jend; j++) { + objPtr = Tcl_NewDoubleObj(mat->me[i][j]); + Tcl_ListObjAppendElement(theInterp, rowPtr, objPtr); + } + Tcl_ListObjAppendElement(theInterp, listPtr, rowPtr); + } + + Tcl_SetObjResult(theInterp, listPtr); + + return TCL_OK; +} + + +//========================================================================== diff --git a/iftcl/If_FloatMat.h b/iftcl/If_FloatMat.h new file mode 100644 index 0000000..732234b --- /dev/null +++ b/iftcl/If_FloatMat.h @@ -0,0 +1,93 @@ +/* + * If_FloatMat.h + * - matrices of floats (currently supported: Meschach MAT*) + * + * rf, 2/7/97 + * + * rf, 8/13/98 + * - use typed Tcl 8 objects instead of strings + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_FloatMat_H +#define If_FloatMat_H + +// Include file with declaration of vector and matrix type. +#include "Meschach.h" + +#include "If_Variable.h" + +// callback for write-access +//-------------------------- +class If_FloatMatWriteIf { + + public: + virtual ~If_FloatMatWriteIf() {} + virtual int write(MAT *newMAT)=0; +}; + +template +class If_FloatMatWriteCB: public If_FloatMatWriteIf { + + protected: + X *_object; + int (X::*_write)(MAT *); + + public: + If_FloatMatWriteCB(int (X::*n_write)(MAT *), X *n_object) + { + assert(n_write != NULL && n_object != NULL); + _write = n_write; + _object = n_object; + } + int write(MAT *newMAT) + { + return (_object->*_write)(newMAT); + } +}; + +// foreward declaration for a MATP +class MATP; + +// class declaration +//------------------ +class If_FloatMat: public If_Variable { + + protected: + + MAT **_varPtr; + If_FloatMatWriteIf *_callback; + + // define abstract methods of If_Variable + //--------------------------------------- + int put(Tcl_Obj *CONST objPtr); + int get(); + + public: + + If_FloatMat(char *ifName, MAT **varPtr, + If_FloatMatWriteIf *callback=NULL); + If_FloatMat(char *ifName, MATP *varPtr, + If_FloatMatWriteIf *callback=NULL); + ~If_FloatMat(); +}; + +#endif diff --git a/iftcl/If_FloatVec.C b/iftcl/If_FloatVec.C new file mode 100644 index 0000000..8a204ea --- /dev/null +++ b/iftcl/If_FloatVec.C @@ -0,0 +1,131 @@ +/* + * If_FloatVec.C -- class definition + * + * rf, 6/22/94 + * + * rf, 2/2/97 + * -- check NULL + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include +#include + +#include "If_FloatVec.h" + +//-------------------------------------------------------------------------- +If_FloatVec::If_FloatVec(char *ifName, VEC **varPtr, + If_FloatVecWriteIf *callback) +:If_Variable(ifName) +{ + _varPtr = varPtr; + _callback = callback; +} + +//-------------------------------------------------------------------------- +If_FloatVec::If_FloatVec(char *ifName, VECP *varPtr, + If_FloatVecWriteIf *callback) +:If_Variable(ifName) +{ + _varPtr = (VEC **)varPtr; + _callback = callback; +} + +//-------------------------------------------------------------------------- +If_FloatVec::~If_FloatVec() +{ + delete _callback; +} + +//-------------------------------------------------------------------------- +int If_FloatVec::put(Tcl_Obj *CONST objPtr) +{ + int j; + int ncols=0; + Tcl_Obj **cols; + double element; + + // split up objPtr into list elements + //----------------------------------- + if (Tcl_ListObjGetElements(theInterp, objPtr, &ncols, &cols) != TCL_OK) { + return TCL_ERROR; + } + + // check dimension + //---------------- + if (*_varPtr == VNULL || ncols != (int)(*_varPtr)->dim) { + Tcl_AppendResult(theInterp, "wrong dimension", NULL); + return TCL_ERROR; + } + + // create and fill a new vector + //----------------------------- + VEC *newVec = v_get(ncols); + + for (j = 0; j < ncols; j++) { + + // parse new value + //---------------- + if(Tcl_GetDoubleFromObj(theInterp, cols[j], &element) != TCL_OK) { + v_free(newVec); + return TCL_ERROR; + } + newVec->ve[j] = element; + } + + // use the new vector + //------------------- + if (_callback) { + if (_callback->write(newVec) != IF_OK) { + Tcl_AppendResult(theInterp, "writing of ", _ifName, " rejected", NULL); + v_free(newVec); + return TCL_ERROR; + } + } + else + *_varPtr = v_copy(newVec, *_varPtr); + + v_free(newVec); + + return TCL_OK; +} + +//-------------------------------------------------------------------------- +int If_FloatVec::get() +{ + VEC *vec = *_varPtr; + int j, jend = vec? vec->dim: 0; + Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL); + Tcl_Obj *objPtr; + + for (j = 0; j < jend; j++) { + objPtr = Tcl_NewDoubleObj(vec->ve[j]); + Tcl_ListObjAppendElement(theInterp, listPtr, objPtr); + } + + Tcl_SetObjResult(theInterp, listPtr); + + return TCL_OK; +} + + +//========================================================================== diff --git a/iftcl/If_FloatVec.h b/iftcl/If_FloatVec.h new file mode 100644 index 0000000..733a4e0 --- /dev/null +++ b/iftcl/If_FloatVec.h @@ -0,0 +1,93 @@ +/* + * If_FloatVec.h + * - vectors of floats (currently supported: Meschach VEC*) + * + * rf, 2/7/97 + * + * rf, 8/13/98 + * - use typed Tcl 8 objects instead of strings + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_FloatVec_H +#define If_FloatVec_H + +// Include file with declaration of vector and matrix type. +#include "Meschach.h" + +#include "If_Variable.h" + +// typedef for a callback for write-access +//---------------------------------------- +class If_FloatVecWriteIf { + + public: + virtual ~If_FloatVecWriteIf() {} + virtual int write(VEC *newVEC)=0; +}; + +template +class If_FloatVecWriteCB: public If_FloatVecWriteIf { + + protected: + X *_object; + int (X::*_write)(VEC *); + + public: + If_FloatVecWriteCB(int (X::*n_write)(VEC *), X *n_object) + { + assert(n_write != NULL && n_object != NULL); + _write = n_write; + _object = n_object; + } + int write(VEC *newVEC) + { + return (_object->*_write)(newVEC); + } +}; + +// foreward declaration for a VECP +class VECP; + +// class declaration +//------------------ +class If_FloatVec: public If_Variable { + + protected: + + VEC **_varPtr; + If_FloatVecWriteIf *_callback; + + // define abstract methods of If_Variable + //--------------------------------------- + int put(Tcl_Obj *CONST objPtr); + int get(); + + public: + + If_FloatVec(char *ifName, VEC **varPtr, + If_FloatVecWriteIf *callback=NULL); + If_FloatVec(char *ifName, VECP *varPtr, + If_FloatVecWriteIf *callback=NULL); + ~If_FloatVec(); +}; + +#endif diff --git a/iftcl/If_Int.C b/iftcl/If_Int.C new file mode 100644 index 0000000..9692be3 --- /dev/null +++ b/iftcl/If_Int.C @@ -0,0 +1,77 @@ +/* + * If_Int.C -- class definition + * + * rf, 6/22/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include "If_Int.h" + +//-------------------------------------------------------------------------- +If_Int::If_Int(char *ifName, If_Int_t *varPtr, If_IntWriteIf *callback) +:If_Variable(ifName) +{ + _varPtr = varPtr; + _callback = callback; +} + +//-------------------------------------------------------------------------- +If_Int::~If_Int() +{ + delete _callback; +} + +//-------------------------------------------------------------------------- +int If_Int::put(Tcl_Obj *CONST objPtr) +{ + If_Int_t value; + + // parse the new value + //-------------------- + if (Tcl_GetIntFromObj(theInterp, objPtr, &value) != TCL_OK) + return TCL_ERROR; + + // use the new value + //------------------ + if (_callback) { + if (_callback->write(value) != IF_OK) { + Tcl_AppendResult(theInterp, "writing of ", _ifName, " rejected", NULL); + return TCL_ERROR; + } + } + else + *_varPtr = value; + + return TCL_OK; +} + +//-------------------------------------------------------------------------- +int If_Int::get() +{ + Tcl_Obj *objPtr = Tcl_NewIntObj(*_varPtr); + + Tcl_SetObjResult(theInterp, objPtr); + + return TCL_OK; +} + + +//========================================================================== diff --git a/iftcl/If_Int.h b/iftcl/If_Int.h new file mode 100644 index 0000000..ea7c44d --- /dev/null +++ b/iftcl/If_Int.h @@ -0,0 +1,88 @@ +/* + * If_Int.h + * - an If_Variable for type Int + * - writing may be protected by an optinal write callback, + * a pointer to it is passed to the constructor and + * deleted by the destuctor + * + * rf, 6/22/94 + * + * rf, 8/13/98 + * - use typed Tcl 8 objects instead of strings + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_Int_H +#define If_Int_H + +#include "If_Variable.h" + +typedef int If_Int_t; + +// callback for write-access +//-------------------------- +class If_IntWriteIf { + + public: + virtual ~If_IntWriteIf() {} + virtual int write(If_Int_t newVal)=0; +}; + +template +class If_IntWriteCB: public If_IntWriteIf { + + protected: + X *_object; + int (X::*_write)(If_Int_t); + + public: + If_IntWriteCB(int (X::*n_write)(If_Int_t), X *n_object) + { + assert(n_write != NULL && n_object != NULL); + _write = n_write; + _object = n_object; + } + int write(If_Int_t newVal) + { + return (_object->*_write)(newVal); + } +}; + +// class declaration +//------------------ +class If_Int: public If_Variable { + + protected: + If_Int_t *_varPtr; + If_IntWriteIf *_callback; + + // define abstract methods of If_Variable + //--------------------------------------- + int put(Tcl_Obj *CONST objPtr); + int get(); + + public: + If_Int(char *ifName, If_Int_t *varPtr, If_IntWriteIf *callback=NULL); + ~If_Int(); +}; + + +#endif diff --git a/iftcl/If_IntVec.C b/iftcl/If_IntVec.C new file mode 100644 index 0000000..2a24492 --- /dev/null +++ b/iftcl/If_IntVec.C @@ -0,0 +1,147 @@ +/* + * If_IntVEC.C -- class definition + * + * rf, 1/31/97 + * + * rf, 2/2/97 + * -- check NULL + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include +#include + +#include "If_IntVec.h" + +//-------------------------------------------------------------------------- +If_IntVec::If_IntVec(char *ifName, IVEC **varPtr, + If_IntVecWriteIf *callback) +:If_Variable(ifName) +{ + _varPtr = varPtr; + _callback = callback; +} + +//-------------------------------------------------------------------------- +If_IntVec::If_IntVec(char *ifName, IVECP *varPtr, + If_IntVecWriteIf *callback) +:If_Variable(ifName) +{ + _varPtr = (IVEC **)varPtr; + _callback = callback; +} + +//-------------------------------------------------------------------------- +If_IntVec::If_IntVec(char *ifName, IVEC **varPtr, const char *mode) +:If_Variable(ifName, mode) +{ + _varPtr = varPtr; + _callback = NULL; +} + +//-------------------------------------------------------------------------- +If_IntVec::If_IntVec(char *ifName, IVECP *varPtr, const char *mode) +:If_Variable(ifName, mode) +{ + _varPtr = (IVEC **)varPtr; + _callback = NULL; +} + +//-------------------------------------------------------------------------- +If_IntVec::~If_IntVec() +{ + delete _callback; +} + +//-------------------------------------------------------------------------- +int If_IntVec::put(Tcl_Obj *CONST objPtr) +{ + int j; + int ncols = 0; + Tcl_Obj **cols; + int element; + + // split up objPtr into list elements + //----------------------------------- + if (Tcl_ListObjGetElements(theInterp, objPtr, &ncols, &cols) != TCL_OK) { + return TCL_ERROR; + } + + // check dimension + //---------------- + if (*_varPtr == IVNULL || ncols != (int)(*_varPtr)->dim) { + Tcl_AppendResult(theInterp, "wrong dimension", NULL); + return TCL_ERROR; + } + + // create and fill a new vector + //----------------------------- + IVEC *newIVEC = iv_get(ncols); + + for (j = 0; j < ncols; j++) { + + // parse new value + //---------------- + if(Tcl_GetIntFromObj(theInterp, cols[j], &element) != TCL_OK) { + iv_free(newIVEC); + return TCL_ERROR; + } + newIVEC->ive[j] = element; + } + + // use the new vector + //------------------- + if (_callback) { + if (_callback->write(newIVEC) != IF_OK) { + Tcl_AppendResult(theInterp, "writing to ", _ifName, " rejected", NULL); + iv_free(newIVEC); + return TCL_ERROR; + } + } + else + *_varPtr = iv_copy(newIVEC, *_varPtr); + + iv_free(newIVEC); + + return TCL_OK; +} + +//-------------------------------------------------------------------------- +int If_IntVec::get() +{ + IVEC *ivec = *_varPtr; + int j, jend = ivec? ivec->dim: 0; + Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL); + Tcl_Obj *objPtr; + + for (j = 0; j < jend; j++) { + objPtr = Tcl_NewIntObj(ivec->ive[j]); + Tcl_ListObjAppendElement(theInterp, listPtr, objPtr); + } + + Tcl_SetObjResult(theInterp, listPtr); + + return TCL_OK; +} + + +//========================================================================== diff --git a/iftcl/If_IntVec.h b/iftcl/If_IntVec.h new file mode 100644 index 0000000..9eb889b --- /dev/null +++ b/iftcl/If_IntVec.h @@ -0,0 +1,93 @@ +/* + * If_IntVec.h + * - integer vectors of the Meschach library + * + * rf, 1/31/97 + * + * rf, 8/13/98 + * - use typed Tcl 8 objects instead of strings + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_IntVec_H +#define If_IntVec_H + +// Include file with declaration of vector and matrix type. +#include "Meschach.h" + +#include "If_Variable.h" + +// typedef for a callback for write-access +//---------------------------------------- +class If_IntVecWriteIf { + + public: + virtual ~If_IntVecWriteIf() {} + virtual int write(IVEC *newIVEC)=0; +}; + +template +class If_IntVecWriteCB: public If_IntVecWriteIf { + + protected: + X *_object; + int (X::*_write)(IVEC *); + + public: + If_IntVecWriteCB(int (X::*n_write)(IVEC *), X *n_object) + { + assert(n_write != NULL && n_object != NULL); + _write = n_write; + _object = n_object; + } + int write(IVEC *newIVEC) + { + return (_object->*_write)(newIVEC); + } +}; + +// foreward declaration for a IVECP +class IVECP; + +// class declaration +//------------------ +class If_IntVec: public If_Variable { + + protected: + + IVEC **_varPtr; + If_IntVecWriteIf *_callback; + + // define abstract methods of If_Variable + //--------------------------------------- + int put(Tcl_Obj *CONST objPtr); + int get(); + + public: + + If_IntVec(char *ifName, IVEC **varPtr, If_IntVecWriteIf *callback=NULL); + If_IntVec(char *ifName, IVECP *varPtr, If_IntVecWriteIf *callback=NULL); + If_IntVec(char *ifName, IVEC **varPtr, const char *mode); + If_IntVec(char *ifName, IVECP *varPtr, const char *mode); + ~If_IntVec(); +}; + +#endif diff --git a/iftcl/If_List.C b/iftcl/If_List.C new file mode 100644 index 0000000..77db119 --- /dev/null +++ b/iftcl/If_List.C @@ -0,0 +1,82 @@ +/* + * If_List.C -- class definition + * + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include + +#include "If_ListElement.h" +#include "If_List.h" + + +//----------------------------------------------------------------------------- +If_List::If_List() +{ + _top= NULL; +} + +//----------------------------------------------------------------------------- +If_List::~If_List() +{ + while (_top) + delete _top; +} + +//----------------------------------------------------------------------------- +void If_List::append(If_ListElement *element) +{ + assert(element->_list == NULL); // may be appended to one list at once + + element->_prev= _top; + element->_next= NULL; + + if (_top) + _top->_next= element; + _top= element; + + element->_list= this; +} + +//----------------------------------------------------------------------------- +void If_List::release(If_ListElement *element) +{ +//printf("list: %d, this: %d, element: %d\n", element->_list, this, element); + if (!element->_list) + return; + + assert(element->_list == this); // is appended to this list + + if(element == _top) + _top= element->_prev; + + if(element->_prev) + element->_prev->_next= element->_next; + + if(element->_next) + element->_next->_prev= element->_prev; + + element->_prev= element->_next= NULL; + element->_list= NULL; +} + + +//============================================================================= diff --git a/iftcl/If_List.h b/iftcl/If_List.h new file mode 100644 index 0000000..b51f4fc --- /dev/null +++ b/iftcl/If_List.h @@ -0,0 +1,55 @@ +/* + * + * If_List.h -- + * - stores a pointer to a list of If_ListElement's + * - many list elements may be concatted + * - destructor deletes all elements + * + * rf, 22/6/94, rev. 1.0 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_List_H +#define If_List_H + +#include "If_ListElement.h" + +#ifndef NULL +#define NULL 0 +#endif + +class If_List { + + protected: + If_ListElement *_top; // top of that list + + public: + If_List(); + ~If_List(); + + void append(If_ListElement *); + void release(If_ListElement *); + + If_ListElement *top() {return _top;} + If_ListElement *prev(If_ListElement *elem) {return elem->_prev;} +}; + +#endif diff --git a/iftcl/If_ListElement.C b/iftcl/If_ListElement.C new file mode 100644 index 0000000..172e678 --- /dev/null +++ b/iftcl/If_ListElement.C @@ -0,0 +1,44 @@ +/* + * If_ListElement.C -- class definition + * + * rf, 6/22/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include "If_List.h" +#include "If_ListElement.h" + +//----------------------------------------------------------------------------- +If_ListElement::If_ListElement() +{ + _list = NULL; + _prev = _next = NULL; +} + +//----------------------------------------------------------------------------- +If_ListElement::~If_ListElement() +{ + if (_list) + _list->release(this); +} + + +//============================================================================= diff --git a/iftcl/If_ListElement.h b/iftcl/If_ListElement.h new file mode 100644 index 0000000..27f3bf1 --- /dev/null +++ b/iftcl/If_ListElement.h @@ -0,0 +1,55 @@ +/* + * If_ListElement.h -- + * - stores a pointer of a If_List + * - stores two pointer for If_List for concatting elements + * + * rf, 6/22/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_ListElement_H +#define If_ListElement_H + +#include + +// fast string comparison +//----------------------- +inline int if_strcmp(const char *str1, const char *str2, int pos=0) +{ + return !(str1[pos] == str2[pos] && strcmp( str1, str2) == 0); +} + +//-------------------- +class If_ListElement { + friend class If_List; + + protected: + If_List *_list; // optional list of that element + If_ListElement *_prev; // previous element + If_ListElement *_next; // next element + + public: + If_ListElement(); + virtual ~If_ListElement(); +}; + + +#endif diff --git a/iftcl/If_Method.h b/iftcl/If_Method.h new file mode 100644 index 0000000..6425b96 --- /dev/null +++ b/iftcl/If_Method.h @@ -0,0 +1,60 @@ +/* + * If_Method.h + * - binds a pointer to a method to an interface command + * - class template (inline code to be compatible with most compilers) + * + * rf, 7/19/94 + * + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_Method_H +#define If_Method_H + +#include "If_Command.h" + + +template +class If_Method: public If_Command { + + protected: + + X *_object; + int (X::*_method)(int, char *[], char **); + + int invoke(int argc, char *argv[], char **result) + { + return (_object->*_method)(argc, argv, result); + } + + public: + + If_Method(char *ifName, + int (X::*method)(int, char *[], char **), X *object) + :If_Command(ifName) + { + _object = object; + _method = method; + } +}; + + +#endif diff --git a/iftcl/If_Module.h b/iftcl/If_Module.h new file mode 100644 index 0000000..9c5e2bc --- /dev/null +++ b/iftcl/If_Module.h @@ -0,0 +1,101 @@ +/* + * If_Module.h + * - binds a pointer to a method to an interface command + * - class template (inline code to be compatible with most compilers) + * + * rf, 7/19/94 + * + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_Module_H +#define If_Module_H + +#include "If_Command.h" +#include "If_Class.h" + +// use this macro to create a new If_Module +//----------------------------------------- +#define IF_MODULE(id, ptr, base) \ + If_Module(id, ptr, theIf_ClassList_##base) + + +template +class If_Module: public If_Command { + + protected: + + X **_module; + If_ClassList*& _list; + + int invoke(int argc, char *argv[], char **result) + { + char *fallback; + + if (argc == 1) { + if (*_module) + *result = (*_module)->name(); + else + *result = "No module chosen."; + return IF_OK; + } + else if (argc == 2) { + if (!_list) { + *result = "No modules available."; + return IF_ERROR; + } + + // store the current module name + if (*_module) + fallback = (*_module)->name(); + else + fallback = NULL; + + // delete the current module to free interface elements + delete *_module; + + // create the requested module + *_module = _list->createObject(argv[1]); + if (!*_module) { + *result = (char *)_list->cand_names(); + if (fallback) + *_module = _list->createObject(fallback); + return IF_ERROR; + } + return IF_OK; + } + + *result = "If_Module: wrong # of args"; + return IF_ERROR; + } + + public: + + If_Module(char *ifName, X **module, If_ClassList*& list) + :If_Command(ifName), + _list(list) + { + _module = module; + } +}; + + +#endif diff --git a/iftcl/If_Proc.C b/iftcl/If_Proc.C new file mode 100644 index 0000000..42a2d28 --- /dev/null +++ b/iftcl/If_Proc.C @@ -0,0 +1,41 @@ +/* + * If_Proc.C -- class definition + * + * rf, 7/20/94 + * + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include "If_Proc.h" + + +//-------------------------------------------------------------------------- +If_Proc::If_Proc(char *ifName, If_Proc_t *proc) +:If_Command(ifName) +{ + _proc = proc; +} + +//-------------------------------------------------------------------------- +int If_Proc::invoke(int argc, char *argv[], char **result) +{ + return (*_proc)(argc, argv, result); +} diff --git a/iftcl/If_Proc.h b/iftcl/If_Proc.h new file mode 100644 index 0000000..a7b2295 --- /dev/null +++ b/iftcl/If_Proc.h @@ -0,0 +1,51 @@ +/* + * If_Proc.h + * - binds a function pointer to an interface command + * + * rf, 7/20/94 + * + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_Proc_H +#define If_Proc_H + +#include "If_Command.h" + + +typedef int If_Proc_t(int argc, char *argv[], char **result); + +//-------------------------------- +class If_Proc: public If_Command { + + protected: + + If_Proc_t *_proc; + + int invoke(int argc, char *argv[], char **); + + public: + + If_Proc(char *ifName, If_Proc_t *proc); +}; + + +#endif diff --git a/iftcl/If_Real.h b/iftcl/If_Real.h new file mode 100644 index 0000000..d56dd33 --- /dev/null +++ b/iftcl/If_Real.h @@ -0,0 +1,34 @@ +/* + * If_Real.h -- + * - new name for If_Float + * + * rf, 12/3/00 + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_Real_H +#define If_Real_H + +#include "If_Float.h" + +typedef If_Float If_Real; + +#endif diff --git a/iftcl/If_RealMat.h b/iftcl/If_RealMat.h new file mode 100644 index 0000000..25e3095 --- /dev/null +++ b/iftcl/If_RealMat.h @@ -0,0 +1,34 @@ +/* + * If_RealMat.h -- + * - new name for If_FloatMat + * + * rf, 12/3/00 + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_RealMat_H +#define If_RealMat_H + +#include "If_FloatMat.h" + +typedef If_FloatMat If_RealMat; + +#endif diff --git a/iftcl/If_RealVec.h b/iftcl/If_RealVec.h new file mode 100644 index 0000000..21aa34b --- /dev/null +++ b/iftcl/If_RealVec.h @@ -0,0 +1,34 @@ +/* + * If_RealVec.h -- + * - new name for If_FloatVec + * + * rf, 12/3/00 + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_RealVec_H +#define If_RealVec_H + +#include "If_FloatVec.h" + +typedef If_FloatVec If_RealVec; + +#endif diff --git a/iftcl/If_Variable.C b/iftcl/If_Variable.C new file mode 100644 index 0000000..e243fa0 --- /dev/null +++ b/iftcl/If_Variable.C @@ -0,0 +1,92 @@ +/* + * If_Variable.C + * + * + * rf, 6/22/94 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#include "If_Variable.h" + +#define IF_READ 1 +#define IF_WRITE 2 + +//-------------------------------------------------------------------------- +If_Variable::If_Variable(const char *ifName, const char *mode) +:If_Element(ifName) +{ + Tcl_CreateObjCommand(theInterp, _ifName, + tclCmd, (ClientData)this, NULL); + + int len = strlen(mode); + _mode = 0; + if (len > 0) { + if (mode[0] == 'r') + _mode |= IF_READ; + if (mode[0] == 'w' || len > 1 && mode[1] == 'w') + _mode |= IF_WRITE; + } +} + +//-------------------------------------------------------------------------- +If_Variable::~If_Variable() +{ + Tcl_DeleteCommand(theInterp, _ifName); +} + +//-------------------------------------------------------------------------- +int If_Variable::tclCmd(ClientData cld, Tcl_Interp *, + int objc, Tcl_Obj *CONST objv[]) +{ + If_Variable *var = (If_Variable *)cld; + + switch (objc) { + + case 1: + if (var->_mode & IF_READ) + return var->get(); + else { + Tcl_AppendResult(theInterp, "read permission denied for ", + var->_ifName, NULL); + return TCL_ERROR; + } + + case 2: + if (var->_mode & IF_WRITE) + return var->put(objv[1]); + else { + Tcl_AppendResult(theInterp, "write permission denied for ", + var->_ifName, NULL); + return TCL_ERROR; + } + + default: + Tcl_AppendResult(theInterp, "wrong # args, should be: ", + var->_ifName, " [new value]", NULL); + return TCL_ERROR; + } +} + + +//========================================================================== diff --git a/iftcl/If_Variable.h b/iftcl/If_Variable.h new file mode 100644 index 0000000..9f13e29 --- /dev/null +++ b/iftcl/If_Variable.h @@ -0,0 +1,61 @@ +/* + * If_Variable.h + * - superclass: If_Element + * - abstract base class for interface-variables to Tcl + * - a derived class converts Tcl data to internal C++ representation + * for one C++ data type + * (see class If_Real for example) + * - has direct access to variables for reading + * - writing can be done with direct access or with a Callback procedure + * + * rf, 6/22/94 + * + * rf, 8/13/98 + * - use typed Tcl 8 objects instead of strings + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_Variable_H +#define If_Variable_H + +#include "If_Element.h" + +class If_Variable: public If_Element { + + protected: + If_Variable(const char *ifName, const char *mode = "rw"); + + // interface to Tcl + //----------------- + static int tclCmd(ClientData, Tcl_Interp*, + int objc, Tcl_Obj *CONST objv[]); + + virtual int put(Tcl_Obj *CONST objPtr) = 0; + virtual int get()=0; + + int _mode; + + public: + virtual ~If_Variable(); +}; + + +#endif diff --git a/iftcl/If_id.h b/iftcl/If_id.h new file mode 100644 index 0000000..5b961fe --- /dev/null +++ b/iftcl/If_id.h @@ -0,0 +1,56 @@ +/* + * fundamental declarations for a framework interface + * + * rf, 10/4/95 + */ + +/* + Copyright (C) 1994--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef If_id_H +#define If_id_H + +#include +#include + +/* + * If_id to address a module trough the interface + */ + +class If_id { + protected: + char *_id; + public: + If_id(const char *id) {_id = strdup(id);} + If_id(const If_id &id) {_id = strdup(id._id);} + ~If_id() {free(_id);} + operator const char* () {return _id;} +}; + +inline int operator == (If_id id1, If_id id2) +{ + return (strcmp(id1, id2) == 0); +} + +inline int operator != (If_id id1, If_id id2) +{ + return (strcmp(id1, id2) != 0); +} + +#endif diff --git a/iftcl/Makefile b/iftcl/Makefile new file mode 100644 index 0000000..f03cc10 --- /dev/null +++ b/iftcl/Makefile @@ -0,0 +1,44 @@ +# Makefile for iftcl +# rf, 6/20/94 +# ("makedepend" is used for depencies) + +include ../makedefs +include ../makedirs + +O = $(OBJ_SUFFIX) + +CCDEFS = $(HQP_INCDIR) $(MES_INCDIR) $(TCL_INCDIR) $(IF_DEFS) + +SRCS = If.C \ + If_List.C \ + If_ListElement.C \ + If_Element.C \ + If_Command.C \ + If_Proc.C \ + If_Variable.C \ + If_Int.C \ + If_Bool.C \ + If_Float.C \ + If_FloatVec.C \ + If_FloatMat.C \ + If_IntVec.C \ + If_Class.C + +OBJS = $(SRCS:.C=$O) + +all: $(OBJS) Makefile + +.C$O: + $(CXX) -c $(CXXFLAGS) $(CCDEFS) $< + +iftest: $(OBJS) iftest$O Makefile + $(CC) -o iftest $(CCFLAGS) $(OBJS) iftest$O \ + ../meschach/*$O ../hqp/sprcm$O -ltcl8.0 -lm -ldl + +depend: + makedepend -- $(CCFLAGS) -- $(SRCS) + +clean: + rm -f *.o *.obj *~ + +# DO NOT DELETE THIS LINE -- make depend depends on it. diff --git a/iftcl/iftest.C b/iftcl/iftest.C new file mode 100644 index 0000000..3a1b605 --- /dev/null +++ b/iftcl/iftest.C @@ -0,0 +1,83 @@ +/* + * Odc_Main.c -- + * + * main function for the Omuses demo collection + * (this file may be replaced by tclAppInit.c or tkAppInit.c of + * a Tcl/Tk distribution, provided that the modules Hqp, Omu, + * and Odc are initialized) + * + * rf, 2/6/97 + */ + +/* + Copyright (C) 1994--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include "If_Int.h" +#include "If_Bool.h" +#include "If_Float.h" +#include "If_FloatVec.h" +#include "If_FloatMat.h" +#include "If_IntVec.h" + +/* + * the main function + */ + +int +main(int argc, char **argv) +{ + Tcl_Main(argc, argv, Tcl_AppInit); + return 0; +} + +/* + * Tcl_AppInit function + */ + +Tcl_Interp *theInterp = NULL; +int if_int = 1234; +double if_float = 1.0/0.0; +bool if_bool = false; +VEC *if_floatVec = VNULL; +MAT *if_floatMat = MNULL; +IVEC *if_intVec = IVNULL; + +int +Tcl_AppInit(Tcl_Interp *interp) +{ + if (Tcl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + + theInterp = interp; + + new If_Int("if_int", &if_int); + new If_Bool("if_bool", &if_bool); + new If_Float("if_float", &if_float); + if_floatVec = v_get(5); + new If_FloatVec("if_floatVec", &if_floatVec); + if_floatMat = m_get(2,3); + new If_FloatMat("if_floatMat", &if_floatMat); + if_intVec = iv_get(3); + new If_IntVec("if_intVec", &if_intVec); + + Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY); + return TCL_OK; +} diff --git a/install-sh b/install-sh new file mode 100755 index 0000000..0ff4b6a --- /dev/null +++ b/install-sh @@ -0,0 +1,119 @@ +#!/bin/sh + +# +# install - install a program, script, or datafile +# This comes from X11R5; it is not part of GNU. +# +# $XConsortium: install.sh,v 1.2 89/12/18 14:47:22 jim Exp $ +# +# This script is compatible with the BSD install script, but was written +# from scratch. +# + + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit="${DOITPROG-}" + + +# put in absolute paths if you don't have them in your path; or use env. vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" + +instcmd="$mvprog" +chmodcmd="" +chowncmd="" +chgrpcmd="" +stripcmd="" +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src="" +dst="" + +while [ x"$1" != x ]; do + case $1 in + -c) instcmd="$cpprog" + shift + continue;; + + -m) chmodcmd="$chmodprog $2" + shift + shift + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + -s) stripcmd="$stripprog" + shift + continue;; + + *) if [ x"$src" = x ] + then + src=$1 + else + dst=$1 + fi + shift + continue;; + esac +done + +if [ x"$src" = x ] +then + echo "install: no input file specified" + exit 1 +fi + +if [ x"$dst" = x ] +then + echo "install: no destination specified" + exit 1 +fi + + +# If destination is a directory, append the input filename; if your system +# does not like double slashes in filenames, you may need to add some logic + +if [ -d $dst ] +then + dst="$dst"/`basename $src` +fi + +# Make a temp file name in the proper directory. + +dstdir=`dirname $dst` +dsttmp=$dstdir/#inst.$$# + +# Move or copy the file name to the temp name + +$doit $instcmd $src $dsttmp + +# and set any options; do chmod last to preserve setuid bits + +if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; fi +if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; fi +if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; fi +if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; fi + +# Now rename the file to the real destination. + +$doit $rmcmd $dst +$doit $mvcmd $dsttmp $dst + + +exit 0 diff --git a/makedefs.in b/makedefs.in new file mode 100644 index 0000000..4f9ade4 --- /dev/null +++ b/makedefs.in @@ -0,0 +1,80 @@ +# +# Definitions used for building HQP +# + +OBJ_SUFFIX = @OBJ_SUFFIX@ +LIB_PREFIX = @LIB_PREFIX@ +LIB_SUFFIX = @LIB_SUFFIX@ +MKLIB_SUFFIX = @MKLIB_SUFFIX@ +LDLIB_PREFIX = @LDLIB_PREFIX@ +LDLIB_SUFFIX = @LDLIB_SUFFIX@ +EXE_SUFFIX = @EXE_SUFFIX@ + +.SUFFIXES: .c .C .f $(OBJ_SUFFIX) $(LIB_SUFFIX) + +CC = @CC@ +CFLAGS = @CFLAGS@ +CXX = @CXX@ +CXXFLAGS = @CXXFLAGS@ + +INSTALL_PREFIX = @prefix@ +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ + +# +# Meschach +# +MES_CC = @MES_CC@ +MES_CFLAGS = @MES_CFLAGS@ +MES_DEFS = -DTRADITIONAL @U_INT_DEF@ + +# +# ADOL-C +# +ADOL_CC = @CXX@ +ADOL_MCC = @CC@ +ADOL_CFLAGS = @CFLAGS@ + +# +# If +# +IF_DEFS = @IF_DEFS@ + +# +# HQP +# IF_CLASS_STATIC -- enforce linking of all modules +# HQP_WITH_CUTE -- include CUTE interface with Hqp +# HQP_WITH_ASCEND -- include Ascend interface with Hqp +# +HQP_DEFS = @DEFS@ @HQP_DEFS@ +HQP_MACH_OBJS = @HQP_MACH_OBJS@ + +# +# Omuses +# OMU_WITH_FORTRAN -- include DASPK and RKsuite (requires f77 or g77) +# +OMU_DEFS = @DEFS@ @OMU_DEFS@ + +FORTRAN_COMP = @FORTRAN_COMP@ +FORTRAN_FLAGS = @FORTRAN_FLAGS@ + +OMU_INTDASPK_C = @OMU_INTDASPK_C@ +DASPK_OBJS = @DASPK_OBJS@ +DASPK = @DASPK@ + +OMU_INTRKSUITE_C = @OMU_INTRKSUITE_C@ +RKSUITE_O = @RKSUITE_O@ + +# +# Interfaces to other packages +# + +CUTE_SRCS = @CUTE_SRCS@ + +ASCEND_SRCS = @ASCEND_SRCS@ + +# +# Linker +# +LD = @LD@ +RANLIB = @RANLIB@ diff --git a/makedirs.in b/makedirs.in new file mode 100644 index 0000000..143d3bd --- /dev/null +++ b/makedirs.in @@ -0,0 +1,14 @@ +# +# Directories used for building HQP +# + +TCL_INCDIR = -I@TCL_INCDIR@ +TCL_LIBDIR = @LFLAG@@TCL_LIBDIR@ @RFLAG@@TCL_LIBDIR@ + +ASCEND_INCDIR = @ASCEND_INCDIR@ + +OMU_INCDIR = -I../omu +ADOL_INCDIR = -I../adol-c/SRC +HQP_INCDIR = -I../hqp +IF_INCDIR = -I../iftcl +MES_INCDIR = -I../meschach diff --git a/malloc/COPYING.LIB b/malloc/COPYING.LIB new file mode 100644 index 0000000..eb685a5 --- /dev/null +++ b/malloc/COPYING.LIB @@ -0,0 +1,481 @@ + GNU LIBRARY GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1991 Free Software Foundation, Inc. + 675 Mass Ave, Cambridge, MA 02139, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the library GPL. It is + numbered 2 because it goes with version 2 of the ordinary GPL.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Library General Public License, applies to some +specially designated Free Software Foundation software, and to any +other libraries whose authors decide to use it. You can use it for +your libraries, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if +you distribute copies of the library, or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link a program with the library, you must provide +complete object files to the recipients so that they can relink them +with the library, after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + Our method of protecting your rights has two steps: (1) copyright +the library, and (2) offer you this license which gives you legal +permission to copy, distribute and/or modify the library. + + Also, for each distributor's protection, we want to make certain +that everyone understands that there is no warranty for this free +library. If the library is modified by someone else and passed on, we +want its recipients to know that what they have is not the original +version, so that any problems introduced by others will not reflect on +the original authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that companies distributing free +software will individually obtain patent licenses, thus in effect +transforming the program into proprietary software. To prevent this, +we have made it clear that any patent must be licensed for everyone's +free use or not licensed at all. + + Most GNU software, including some libraries, is covered by the ordinary +GNU General Public License, which was designed for utility programs. This +license, the GNU Library General Public License, applies to certain +designated libraries. This license is quite different from the ordinary +one; be sure to read it in full, and don't assume that anything in it is +the same as in the ordinary license. + + The reason we have a separate public license for some libraries is that +they blur the distinction we usually make between modifying or adding to a +program and simply using it. Linking a program with a library, without +changing the library, is in some sense simply using the library, and is +analogous to running a utility program or application program. However, in +a textual and legal sense, the linked executable is a combined work, a +derivative of the original library, and the ordinary General Public License +treats it as such. + + Because of this blurred distinction, using the ordinary General +Public License for libraries did not effectively promote software +sharing, because most developers did not use the libraries. We +concluded that weaker conditions might promote sharing better. + + However, unrestricted linking of non-free programs would deprive the +users of those programs of all benefit from the free status of the +libraries themselves. This Library General Public License is intended to +permit developers of non-free programs to use free libraries, while +preserving your freedom as a user of such programs to change the free +libraries that are incorporated in them. (We have not seen how to achieve +this as regards changes in header files, but we have achieved it as regards +changes in the actual functions of the Library.) The hope is that this +will lead to faster development of free libraries. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, while the latter only +works together with the library. + + Note that it is possible for a library to be covered by the ordinary +General Public License rather than by this special one. + + GNU LIBRARY GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library which +contains a notice placed by the copyright holder or other authorized +party saying it may be distributed under the terms of this Library +General Public License (also called "this License"). Each licensee is +addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also compile or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + c) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + d) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the source code distributed need not include anything that is normally +distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Library General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/malloc/ChangeLog b/malloc/ChangeLog new file mode 100644 index 0000000..74a985a --- /dev/null +++ b/malloc/ChangeLog @@ -0,0 +1,2 @@ + +Find older changes in OChangeLog. diff --git a/malloc/Makefile b/malloc/Makefile new file mode 100644 index 0000000..36f66aa --- /dev/null +++ b/malloc/Makefile @@ -0,0 +1,57 @@ +# Copyright (C) 1991, 1992, 1993 Free Software Foundation, Inc. +# This file is part of the GNU C Library. + +# The GNU C Library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Library General Public License +# as published by the Free Software Foundation; either version 2 of +# the License, or (at your option) any later version. + +# The GNU C Library 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 +# Library General Public License for more details. + +# You should have received a copy of the GNU Library General Public +# License along with the GNU C Library; see the file COPYING.LIB. If +# not, write to the Free Software Foundation, Inc., 675 Mass Ave, +# Cambridge, MA 02139, USA. + +# Makefile for standalone distribution of malloc. + +# Use this on System V. +#CPPFLAGS = -DUSG + +.PHONY: all +all: libmalloc.a gmalloc.o + +gmalloc = valloc.c malloc.c free.c cfree.c realloc.c calloc.c morecore.c memalign.c +sources = valloc.c malloc.c free.c cfree.c realloc.c calloc.c morecore.c memalign.c mcheck.c mtrace.c mstats.c vm-limit.c ralloc.c malloc-find.c +objects = valloc.o malloc.o free.o cfree.o realloc.o calloc.o morecore.o memalign.o mcheck.o mtrace.o mstats.o vm-limit.o ralloc.o malloc-find.o +headers = malloc.h + +libmalloc.a: $(objects) + ar crv $@ $(objects) + ranlib $@ + +$(objects): $(headers) + +gmalloc.c: gmalloc-head.c $(headers) $(gmalloc) Makefile + cat gmalloc-head.c $(headers) $(gmalloc) > $@-tmp + mv -f $@-tmp $@ +# Make it unwritable to avoid accidentally changing the file, +# since it is generated and any changes would be lost. + chmod a-w $@ + +.c.o: + $(CC) $(CFLAGS) $(CPPFLAGS) -I. -c $< $(OUTPUT_OPTION) + +.PHONY: clean realclean malloc-clean malloc-realclean +clean malloc-clean: + -rm -f libmalloc.a *.o core +realclean malloc-realclean: clean + -rm -f TAGS tags *~ + +# For inside the C library. +malloc.tar malloc.tar.Z: FORCE + $(MAKE) -C .. $@ +FORCE: diff --git a/malloc/OChangeLog b/malloc/OChangeLog new file mode 100644 index 0000000..452aa53 --- /dev/null +++ b/malloc/OChangeLog @@ -0,0 +1,34 @@ + **** All newer entries are in the C library ChangeLog file. **** + +Thu Jul 11 18:15:04 1991 Roland McGrath (roland@churchy.gnu.ai.mit.edu) + + * Merged with C library version, which now has its own subdir. + * malloc.h, *.c: Use ansideclisms and #ifdefs for portability both + in and out of the C library. + * Makefile: New makefile for malloc subdir in libc. + Has targets to create malloc.tar{,.Z} by ansidecl processing on srcs. + * malloc/Makefile: New file; Makefile for standalone distribution. + * malloc/README: New file; info for same. + +Fri Apr 6 00:18:36 1990 Jim Kingdon (kingdon at pogo.ai.mit.edu) + + * Makefile: Add comments. + +Thu Apr 5 23:08:14 1990 Mike Haertel (mike at albert.ai.mit.edu) + + * mcheck.c (mcheck, checkhdr): Support user-supplied abort() + function. + * malloc.h: Declare __free(). + * Makefile: New target libmalloc.a. + +Thu Apr 5 21:56:03 1990 Jim Kingdon (kingdon at pogo.ai.mit.edu) + + * free.c (free): Split into free and __free. + * malloc.c (morecore): Call __free on oldinfo. + +Local Variables: +mode: indented-text +left-margin: 8 +fill-column: 76 +version-control: never +End: diff --git a/malloc/README b/malloc/README new file mode 100644 index 0000000..b5655c9 --- /dev/null +++ b/malloc/README @@ -0,0 +1,12 @@ +This is the standalone distribution of GNU malloc. +GNU malloc is part of the GNU C Library, but is also distributed separately. + +If you find bugs in GNU malloc, send reports to bug-glibc@prep.ai.mit.edu. + +GNU malloc is free software. See the file COPYING.LIB for copying conditions. + +The makefile builds libmalloc.a and gmalloc.o. If you are using GNU malloc +to replace your system's existing malloc package, it is important to make +sure you get all GNU functions, not some of the GNU functions and some from +the system library. gmalloc.o has all the functions in one file, so using +that will make sure you don't accidentally mix the two malloc packages. diff --git a/malloc/calloc.c b/malloc/calloc.c new file mode 100644 index 0000000..3db5f74 --- /dev/null +++ b/malloc/calloc.c @@ -0,0 +1,39 @@ +/* Copyright (C) 1991, 1992, 1994 Free Software Foundation, Inc. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +/* Allocate an array of NMEMB elements each SIZE bytes long. + The entire array is initialized to zeros. */ +__ptr_t +calloc (nmemb, size) + register __malloc_size_t nmemb; + register __malloc_size_t size; +{ + register __ptr_t result = malloc (nmemb * size); + + if (result != NULL) + (void) memset (result, 0, nmemb * size); + + return result; +} diff --git a/malloc/cfree.c b/malloc/cfree.c new file mode 100644 index 0000000..cc61481 --- /dev/null +++ b/malloc/cfree.c @@ -0,0 +1,43 @@ +/* Copyright (C) 1991, 1993, 1994 Free Software Foundation, Inc. +This file is part of the GNU C Library. + +The GNU C Library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +The GNU C Library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with the GNU C Library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +#ifdef _LIBC + +#include +#include + +#undef cfree + +function_alias(cfree, free, void, (ptr), + DEFUN(cfree, (ptr), PTR ptr)) + +#else + +void +cfree (ptr) + __ptr_t ptr; +{ + free (ptr); +} + +#endif diff --git a/malloc/free.c b/malloc/free.c new file mode 100644 index 0000000..e7fc08c --- /dev/null +++ b/malloc/free.c @@ -0,0 +1,210 @@ +/* Free a block of memory allocated by `malloc'. + Copyright 1990, 1991, 1992, 1994 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +/* Debugging hook for free. */ +void (*__free_hook) __P ((__ptr_t __ptr)); + +/* List of blocks allocated by memalign. */ +struct alignlist *_aligned_blocks = NULL; + +/* Return memory to the heap. + Like `free' but don't call a __free_hook if there is one. */ +void +_free_internal (ptr) + __ptr_t ptr; +{ + int type; + __malloc_size_t block, blocks; + register __malloc_size_t i; + struct list *prev, *next; + + block = BLOCK (ptr); + + type = _heapinfo[block].busy.type; + switch (type) + { + case 0: + /* Get as many statistics as early as we can. */ + --_chunks_used; + _bytes_used -= _heapinfo[block].busy.info.size * BLOCKSIZE; + _bytes_free += _heapinfo[block].busy.info.size * BLOCKSIZE; + + /* Find the free cluster previous to this one in the free list. + Start searching at the last block referenced; this may benefit + programs with locality of allocation. */ + i = _heapindex; + if (i > block) + while (i > block) + i = _heapinfo[i].free.prev; + else + { + do + i = _heapinfo[i].free.next; + while (i > 0 && i < block); + i = _heapinfo[i].free.prev; + } + + /* Determine how to link this block into the free list. */ + if (block == i + _heapinfo[i].free.size) + { + /* Coalesce this block with its predecessor. */ + _heapinfo[i].free.size += _heapinfo[block].busy.info.size; + block = i; + } + else + { + /* Really link this block back into the free list. */ + _heapinfo[block].free.size = _heapinfo[block].busy.info.size; + _heapinfo[block].free.next = _heapinfo[i].free.next; + _heapinfo[block].free.prev = i; + _heapinfo[i].free.next = block; + _heapinfo[_heapinfo[block].free.next].free.prev = block; + ++_chunks_free; + } + + /* Now that the block is linked in, see if we can coalesce it + with its successor (by deleting its successor from the list + and adding in its size). */ + if (block + _heapinfo[block].free.size == _heapinfo[block].free.next) + { + _heapinfo[block].free.size + += _heapinfo[_heapinfo[block].free.next].free.size; + _heapinfo[block].free.next + = _heapinfo[_heapinfo[block].free.next].free.next; + _heapinfo[_heapinfo[block].free.next].free.prev = block; + --_chunks_free; + } + + /* Now see if we can return stuff to the system. */ + blocks = _heapinfo[block].free.size; + if (blocks >= FINAL_FREE_BLOCKS && block + blocks == _heaplimit + && (*__morecore) (0) == ADDRESS (block + blocks)) + { + register __malloc_size_t bytes = blocks * BLOCKSIZE; + _heaplimit -= blocks; + (*__morecore) (-bytes); + _heapinfo[_heapinfo[block].free.prev].free.next + = _heapinfo[block].free.next; + _heapinfo[_heapinfo[block].free.next].free.prev + = _heapinfo[block].free.prev; + block = _heapinfo[block].free.prev; + --_chunks_free; + _bytes_free -= bytes; + } + + /* Set the next search to begin at this block. */ + _heapindex = block; + break; + + default: + /* Do some of the statistics. */ + --_chunks_used; + _bytes_used -= 1 << type; + ++_chunks_free; + _bytes_free += 1 << type; + + /* Get the address of the first free fragment in this block. */ + prev = (struct list *) ((char *) ADDRESS (block) + + (_heapinfo[block].busy.info.frag.first << type)); + + if (_heapinfo[block].busy.info.frag.nfree == (BLOCKSIZE >> type) - 1) + { + /* If all fragments of this block are free, remove them + from the fragment list and free the whole block. */ + next = prev; + for (i = 1; i < (__malloc_size_t) (BLOCKSIZE >> type); ++i) + next = next->next; + prev->prev->next = next; + if (next != NULL) + next->prev = prev->prev; + _heapinfo[block].busy.type = 0; + _heapinfo[block].busy.info.size = 1; + + /* Keep the statistics accurate. */ + ++_chunks_used; + _bytes_used += BLOCKSIZE; + _chunks_free -= BLOCKSIZE >> type; + _bytes_free -= BLOCKSIZE; + + free (ADDRESS (block)); + } + else if (_heapinfo[block].busy.info.frag.nfree != 0) + { + /* If some fragments of this block are free, link this + fragment into the fragment list after the first free + fragment of this block. */ + next = (struct list *) ptr; + next->next = prev->next; + next->prev = prev; + prev->next = next; + if (next->next != NULL) + next->next->prev = next; + ++_heapinfo[block].busy.info.frag.nfree; + } + else + { + /* No fragments of this block are free, so link this + fragment into the fragment list and announce that + it is the first free fragment of this block. */ + prev = (struct list *) ptr; + _heapinfo[block].busy.info.frag.nfree = 1; + _heapinfo[block].busy.info.frag.first = (unsigned long int) + ((unsigned long int) ((char *) ptr - (char *) NULL) + % BLOCKSIZE >> type); + prev->next = _fraghead[type].next; + prev->prev = &_fraghead[type]; + prev->prev->next = prev; + if (prev->next != NULL) + prev->next->prev = prev; + } + break; + } +} + +/* Return memory to the heap. */ +void +free (ptr) + __ptr_t ptr; +{ + register struct alignlist *l; + + if (ptr == NULL) + return; + + for (l = _aligned_blocks; l != NULL; l = l->next) + if (l->aligned == ptr) + { + l->aligned = NULL; /* Mark the slot in the list as free. */ + ptr = l->exact; + break; + } + + if (__free_hook != NULL) + (*__free_hook) (ptr); + else + _free_internal (ptr); +} diff --git a/malloc/getpagesize.h b/malloc/getpagesize.h new file mode 100644 index 0000000..ef7e45d --- /dev/null +++ b/malloc/getpagesize.h @@ -0,0 +1,39 @@ +/* Emulate getpagesize on systems that lack it. */ + +#ifndef HAVE_GETPAGESIZE + +#ifdef VMS +#define getpagesize() 512 +#endif + +#ifdef HAVE_UNISTD_H +#include +#endif + +#ifdef _SC_PAGESIZE +#define getpagesize() sysconf(_SC_PAGESIZE) +#else + +#include + +#ifdef EXEC_PAGESIZE +#define getpagesize() EXEC_PAGESIZE +#else +#ifdef NBPG +#define getpagesize() NBPG * CLSIZE +#ifndef CLSIZE +#define CLSIZE 1 +#endif /* no CLSIZE */ +#else /* no NBPG */ +#ifdef NBPC +#define getpagesize() NBPC +#else /* no NBPC */ +#ifdef PAGESIZE +#define getpagesize() PAGESIZE +#endif +#endif /* NBPC */ +#endif /* no NBPG */ +#endif /* no EXEC_PAGESIZE */ +#endif /* no _SC_PAGESIZE */ + +#endif /* not HAVE_GETPAGESIZE */ diff --git a/malloc/gmalloc-head.c b/malloc/gmalloc-head.c new file mode 100644 index 0000000..e5f82c3 --- /dev/null +++ b/malloc/gmalloc-head.c @@ -0,0 +1,6 @@ +/* DO NOT EDIT THIS FILE -- it is automagically generated. -*- C -*- */ + +#define _MALLOC_INTERNAL + +/* The malloc headers and source files from the C library follow here. */ + diff --git a/malloc/gmalloc.c b/malloc/gmalloc.c new file mode 100644 index 0000000..859a297 --- /dev/null +++ b/malloc/gmalloc.c @@ -0,0 +1,1350 @@ +/* DO NOT EDIT THIS FILE -- it is automagically generated. -*- C -*- */ + +#define _MALLOC_INTERNAL + +/* The malloc headers and source files from the C library follow here. */ + +/* Declarations for `malloc' and friends. + Copyright 1990, 1991, 1992, 1993, 1995 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef _MALLOC_H + +#define _MALLOC_H 1 + +#ifdef _MALLOC_INTERNAL + +#ifdef HAVE_CONFIG_H +#include +#endif + +#if defined(_LIBC) || defined(STDC_HEADERS) || defined(USG) +#include +#else +#ifndef memset +#define memset(s, zero, n) bzero ((s), (n)) +#endif +#ifndef memcpy +#define memcpy(d, s, n) bcopy ((s), (d), (n)) +#endif +#endif + +#if defined (__GNU_LIBRARY__) || (defined (__STDC__) && __STDC__) +#include +#else +#ifndef CHAR_BIT +#define CHAR_BIT 8 +#endif +#endif + +#ifdef HAVE_UNISTD_H +#include +#endif + +#endif /* _MALLOC_INTERNAL. */ + + +#ifdef __cplusplus +extern "C" +{ +#endif + +#if defined (__cplusplus) || (defined (__STDC__) && __STDC__) +#undef __P +#define __P(args) args +#undef __ptr_t +#define __ptr_t void * +#else /* Not C++ or ANSI C. */ +#undef __P +#define __P(args) () +#undef const +#define const +#undef __ptr_t +#define __ptr_t char * +#endif /* C++ or ANSI C. */ + +#if defined (__STDC__) && __STDC__ +#include +#define __malloc_size_t size_t +#define __malloc_ptrdiff_t ptrdiff_t +#else +#define __malloc_size_t unsigned int +#define __malloc_ptrdiff_t int +#endif + +#ifndef NULL +#define NULL 0 +#endif + + +/* Allocate SIZE bytes of memory. */ +extern __ptr_t malloc __P ((__malloc_size_t __size)); +/* Re-allocate the previously allocated block + in __ptr_t, making the new block SIZE bytes long. */ +extern __ptr_t realloc __P ((__ptr_t __ptr, __malloc_size_t __size)); +/* Allocate NMEMB elements of SIZE bytes each, all initialized to 0. */ +extern __ptr_t calloc __P ((__malloc_size_t __nmemb, __malloc_size_t __size)); +/* Free a block allocated by `malloc', `realloc' or `calloc'. */ +extern void free __P ((__ptr_t __ptr)); + +/* Allocate SIZE bytes allocated to ALIGNMENT bytes. */ +extern __ptr_t memalign __P ((__malloc_size_t __alignment, + __malloc_size_t __size)); + +/* Allocate SIZE bytes on a page boundary. */ +extern __ptr_t valloc __P ((__malloc_size_t __size)); + + +#ifdef _MALLOC_INTERNAL + +/* The allocator divides the heap into blocks of fixed size; large + requests receive one or more whole blocks, and small requests + receive a fragment of a block. Fragment sizes are powers of two, + and all fragments of a block are the same size. When all the + fragments in a block have been freed, the block itself is freed. */ +#define INT_BIT (CHAR_BIT * sizeof(int)) +#define BLOCKLOG (INT_BIT > 16 ? 12 : 9) +#define BLOCKSIZE (1 << BLOCKLOG) +#define BLOCKIFY(SIZE) (((SIZE) + BLOCKSIZE - 1) / BLOCKSIZE) + +/* Determine the amount of memory spanned by the initial heap table + (not an absolute limit). */ +#define HEAP (INT_BIT > 16 ? 4194304 : 65536) + +/* Number of contiguous free blocks allowed to build up at the end of + memory before they will be returned to the system. */ +#define FINAL_FREE_BLOCKS 8 + +/* Data structure giving per-block information. */ +typedef union + { + /* Heap information for a busy block. */ + struct + { + /* Zero for a large (multiblock) object, or positive giving the + logarithm to the base two of the fragment size. */ + int type; + union + { + struct + { + __malloc_size_t nfree; /* Free frags in a fragmented block. */ + __malloc_size_t first; /* First free fragment of the block. */ + } frag; + /* For a large object, in its first block, this has the number + of blocks in the object. In the other blocks, this has a + negative number which says how far back the first block is. */ + __malloc_ptrdiff_t size; + } info; + } busy; + /* Heap information for a free block + (that may be the first of a free cluster). */ + struct + { + __malloc_size_t size; /* Size (in blocks) of a free cluster. */ + __malloc_size_t next; /* Index of next free cluster. */ + __malloc_size_t prev; /* Index of previous free cluster. */ + } free; + } malloc_info; + +/* Pointer to first block of the heap. */ +extern char *_heapbase; + +/* Table indexed by block number giving per-block information. */ +extern malloc_info *_heapinfo; + +/* Address to block number and vice versa. */ +#define BLOCK(A) (((char *) (A) - _heapbase) / BLOCKSIZE + 1) +#define ADDRESS(B) ((__ptr_t) (((B) - 1) * BLOCKSIZE + _heapbase)) + +/* Current search index for the heap table. */ +extern __malloc_size_t _heapindex; + +/* Limit of valid info table indices. */ +extern __malloc_size_t _heaplimit; + +/* Doubly linked lists of free fragments. */ +struct list + { + struct list *next; + struct list *prev; + }; + +/* Free list headers for each fragment size. */ +extern struct list _fraghead[]; + +/* List of blocks allocated with `memalign' (or `valloc'). */ +struct alignlist + { + struct alignlist *next; + __ptr_t aligned; /* The address that memaligned returned. */ + __ptr_t exact; /* The address that malloc returned. */ + }; +extern struct alignlist *_aligned_blocks; + +/* Instrumentation. */ +extern __malloc_size_t _chunks_used; +extern __malloc_size_t _bytes_used; +extern __malloc_size_t _chunks_free; +extern __malloc_size_t _bytes_free; + +/* Internal version of `free' used in `morecore' (malloc.c). */ +extern void _free_internal __P ((__ptr_t __ptr)); + +#endif /* _MALLOC_INTERNAL. */ + +/* Given an address in the middle of a malloc'd object, + return the address of the beginning of the object. */ +extern __ptr_t malloc_find_object_address __P ((__ptr_t __ptr)); + +/* Underlying allocation function; successive calls should + return contiguous pieces of memory. */ +extern __ptr_t (*__morecore) __P ((__malloc_ptrdiff_t __size)); + +/* Default value of `__morecore'. */ +extern __ptr_t __default_morecore __P ((__malloc_ptrdiff_t __size)); + +/* If not NULL, this function is called after each time + `__morecore' is called to increase the data size. */ +extern void (*__after_morecore_hook) __P ((void)); + +/* Nonzero if `malloc' has been called and done its initialization. */ +extern int __malloc_initialized; + +/* Hooks for debugging versions. */ +extern void (*__malloc_initialize_hook) __P ((void)); +extern void (*__free_hook) __P ((__ptr_t __ptr)); +extern __ptr_t (*__malloc_hook) __P ((__malloc_size_t __size)); +extern __ptr_t (*__realloc_hook) __P ((__ptr_t __ptr, __malloc_size_t __size)); +extern __ptr_t (*__memalign_hook) __P ((__malloc_size_t __size, + __malloc_size_t __alignment)); + +/* Return values for `mprobe': these are the kinds of inconsistencies that + `mcheck' enables detection of. */ +enum mcheck_status + { + MCHECK_DISABLED = -1, /* Consistency checking is not turned on. */ + MCHECK_OK, /* Block is fine. */ + MCHECK_FREE, /* Block freed twice. */ + MCHECK_HEAD, /* Memory before the block was clobbered. */ + MCHECK_TAIL /* Memory after the block was clobbered. */ + }; + +/* Activate a standard collection of debugging hooks. This must be called + before `malloc' is ever called. ABORTFUNC is called with an error code + (see enum above) when an inconsistency is detected. If ABORTFUNC is + null, the standard function prints on stderr and then calls `abort'. */ +extern int mcheck __P ((void (*__abortfunc) __P ((enum mcheck_status)))); + +/* Check for aberrations in a particular malloc'd block. You must have + called `mcheck' already. These are the same checks that `mcheck' does + when you free or reallocate a block. */ +extern enum mcheck_status mprobe __P ((__ptr_t __ptr)); + +/* Activate a standard collection of tracing hooks. */ +extern void mtrace __P ((void)); +extern void muntrace __P ((void)); + +/* Statistics available to the user. */ +struct mstats + { + __malloc_size_t bytes_total; /* Total size of the heap. */ + __malloc_size_t chunks_used; /* Chunks allocated by the user. */ + __malloc_size_t bytes_used; /* Byte total of user-allocated chunks. */ + __malloc_size_t chunks_free; /* Chunks in the free list. */ + __malloc_size_t bytes_free; /* Byte total of chunks in the free list. */ + }; + +/* Pick up the current statistics. */ +extern struct mstats mstats __P ((void)); + +/* Call WARNFUN with a warning message when memory usage is high. */ +extern void memory_warnings __P ((__ptr_t __start, + void (*__warnfun) __P ((const char *)))); + + +/* Relocating allocator. */ + +/* Allocate SIZE bytes, and store the address in *HANDLEPTR. */ +extern __ptr_t r_alloc __P ((__ptr_t *__handleptr, __malloc_size_t __size)); + +/* Free the storage allocated in HANDLEPTR. */ +extern void r_alloc_free __P ((__ptr_t *__handleptr)); + +/* Adjust the block at HANDLEPTR to be SIZE bytes long. */ +extern __ptr_t r_re_alloc __P ((__ptr_t *__handleptr, __malloc_size_t __size)); + + +#ifdef __cplusplus +} +#endif + +#endif /* malloc.h */ +/* Allocate memory on a page boundary. + Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#if defined (__GNU_LIBRARY__) || defined (_LIBC) +#include +#include +extern size_t __getpagesize __P ((void)); +#else +#include "getpagesize.h" +#define __getpagesize() getpagesize() +#endif + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +static __malloc_size_t pagesize; + +__ptr_t +valloc (size) + __malloc_size_t size; +{ + if (pagesize == 0) + pagesize = __getpagesize (); + + return memalign (pagesize, size); +} +/* Memory allocator `malloc'. + Copyright 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +/* How to really get more memory. */ +__ptr_t (*__morecore) __P ((ptrdiff_t __size)) = __default_morecore; + +/* Debugging hook for `malloc'. */ +__ptr_t (*__malloc_hook) __P ((__malloc_size_t __size)); + +/* Pointer to the base of the first block. */ +char *_heapbase; + +/* Block information table. Allocated with align/__free (not malloc/free). */ +malloc_info *_heapinfo; + +/* Number of info entries. */ +static __malloc_size_t heapsize; + +/* Search index in the info table. */ +__malloc_size_t _heapindex; + +/* Limit of valid info table indices. */ +__malloc_size_t _heaplimit; + +/* Free lists for each fragment size. */ +struct list _fraghead[BLOCKLOG]; + +/* Instrumentation. */ +__malloc_size_t _chunks_used; +__malloc_size_t _bytes_used; +__malloc_size_t _chunks_free; +__malloc_size_t _bytes_free; + +/* Are you experienced? */ +int __malloc_initialized; + +void (*__malloc_initialize_hook) __P ((void)); +void (*__after_morecore_hook) __P ((void)); + +/* Aligned allocation. */ +static __ptr_t align __P ((__malloc_size_t)); +static __ptr_t +align (size) + __malloc_size_t size; +{ + __ptr_t result; + unsigned long int adj; + + result = (*__morecore) (size); + adj = (unsigned long int) ((unsigned long int) ((char *) result - + (char *) NULL)) % BLOCKSIZE; + if (adj != 0) + { + adj = BLOCKSIZE - adj; + (void) (*__morecore) (adj); + result = (char *) result + adj; + } + + if (__after_morecore_hook) + (*__after_morecore_hook) (); + + return result; +} + +/* Set everything up and remember that we have. */ +static int initialize __P ((void)); +static int +initialize () +{ + if (__malloc_initialize_hook) + (*__malloc_initialize_hook) (); + + heapsize = HEAP / BLOCKSIZE; + _heapinfo = (malloc_info *) align (heapsize * sizeof (malloc_info)); + if (_heapinfo == NULL) + return 0; + memset (_heapinfo, 0, heapsize * sizeof (malloc_info)); + _heapinfo[0].free.size = 0; + _heapinfo[0].free.next = _heapinfo[0].free.prev = 0; + _heapindex = 0; + _heapbase = (char *) _heapinfo; + + /* Account for the _heapinfo block itself in the statistics. */ + _bytes_used = heapsize * sizeof (malloc_info); + _chunks_used = 1; + + __malloc_initialized = 1; + return 1; +} + +/* Get neatly aligned memory, initializing or + growing the heap info table as necessary. */ +static __ptr_t morecore __P ((__malloc_size_t)); +static __ptr_t +morecore (size) + __malloc_size_t size; +{ + __ptr_t result; + malloc_info *newinfo, *oldinfo; + __malloc_size_t newsize; + + result = align (size); + if (result == NULL) + return NULL; + + /* Check if we need to grow the info table. */ + if ((__malloc_size_t) BLOCK ((char *) result + size) > heapsize) + { + newsize = heapsize; + while ((__malloc_size_t) BLOCK ((char *) result + size) > newsize) + newsize *= 2; + newinfo = (malloc_info *) align (newsize * sizeof (malloc_info)); + if (newinfo == NULL) + { + (*__morecore) (-size); + return NULL; + } + memcpy (newinfo, _heapinfo, heapsize * sizeof (malloc_info)); + memset (&newinfo[heapsize], 0, + (newsize - heapsize) * sizeof (malloc_info)); + oldinfo = _heapinfo; + newinfo[BLOCK (oldinfo)].busy.type = 0; + newinfo[BLOCK (oldinfo)].busy.info.size + = BLOCKIFY (heapsize * sizeof (malloc_info)); + _heapinfo = newinfo; + /* Account for the _heapinfo block itself in the statistics. */ + _bytes_used += newsize * sizeof (malloc_info); + ++_chunks_used; + _free_internal (oldinfo); + heapsize = newsize; + } + + _heaplimit = BLOCK ((char *) result + size); + return result; +} + +/* Allocate memory from the heap. */ +__ptr_t +malloc (size) + __malloc_size_t size; +{ + __ptr_t result; + __malloc_size_t block, blocks, lastblocks, start; + register __malloc_size_t i; + struct list *next; + + /* ANSI C allows `malloc (0)' to either return NULL, or to return a + valid address you can realloc and free (though not dereference). + + It turns out that some extant code (sunrpc, at least Ultrix's version) + expects `malloc (0)' to return non-NULL and breaks otherwise. + Be compatible. */ + +#if 0 + if (size == 0) + return NULL; +#endif + + if (__malloc_hook != NULL) + return (*__malloc_hook) (size); + + if (!__malloc_initialized) + if (!initialize ()) + return NULL; + + if (size < sizeof (struct list)) + size = sizeof (struct list); + +#ifdef SUNOS_LOCALTIME_BUG + if (size < 16) + size = 16; +#endif + + /* Determine the allocation policy based on the request size. */ + if (size <= BLOCKSIZE / 2) + { + /* Small allocation to receive a fragment of a block. + Determine the logarithm to base two of the fragment size. */ + register __malloc_size_t log = 1; + --size; + while ((size /= 2) != 0) + ++log; + + /* Look in the fragment lists for a + free fragment of the desired size. */ + next = _fraghead[log].next; + if (next != NULL) + { + /* There are free fragments of this size. + Pop a fragment out of the fragment list and return it. + Update the block's nfree and first counters. */ + result = (__ptr_t) next; + next->prev->next = next->next; + if (next->next != NULL) + next->next->prev = next->prev; + block = BLOCK (result); + if (--_heapinfo[block].busy.info.frag.nfree != 0) + _heapinfo[block].busy.info.frag.first = (unsigned long int) + ((unsigned long int) ((char *) next->next - (char *) NULL) + % BLOCKSIZE) >> log; + + /* Update the statistics. */ + ++_chunks_used; + _bytes_used += 1 << log; + --_chunks_free; + _bytes_free -= 1 << log; + } + else + { + /* No free fragments of the desired size, so get a new block + and break it into fragments, returning the first. */ + result = malloc (BLOCKSIZE); + if (result == NULL) + return NULL; + + /* Link all fragments but the first into the free list. */ + for (i = 1; i < (__malloc_size_t) (BLOCKSIZE >> log); ++i) + { + next = (struct list *) ((char *) result + (i << log)); + next->next = _fraghead[log].next; + next->prev = &_fraghead[log]; + next->prev->next = next; + if (next->next != NULL) + next->next->prev = next; + } + + /* Initialize the nfree and first counters for this block. */ + block = BLOCK (result); + _heapinfo[block].busy.type = log; + _heapinfo[block].busy.info.frag.nfree = i - 1; + _heapinfo[block].busy.info.frag.first = i - 1; + + _chunks_free += (BLOCKSIZE >> log) - 1; + _bytes_free += BLOCKSIZE - (1 << log); + _bytes_used -= BLOCKSIZE - (1 << log); + } + } + else + { + /* Large allocation to receive one or more blocks. + Search the free list in a circle starting at the last place visited. + If we loop completely around without finding a large enough + space we will have to get more memory from the system. */ + blocks = BLOCKIFY (size); + start = block = _heapindex; + while (_heapinfo[block].free.size < blocks) + { + block = _heapinfo[block].free.next; + if (block == start) + { + /* Need to get more from the system. Check to see if + the new core will be contiguous with the final free + block; if so we don't need to get as much. */ + block = _heapinfo[0].free.prev; + lastblocks = _heapinfo[block].free.size; + if (_heaplimit != 0 && block + lastblocks == _heaplimit && + (*__morecore) (0) == ADDRESS (block + lastblocks) && + (morecore ((blocks - lastblocks) * BLOCKSIZE)) != NULL) + { + /* Which block we are extending (the `final free + block' referred to above) might have changed, if + it got combined with a freed info table. */ + block = _heapinfo[0].free.prev; + _heapinfo[block].free.size += (blocks - lastblocks); + _bytes_free += (blocks - lastblocks) * BLOCKSIZE; + continue; + } + result = morecore (blocks * BLOCKSIZE); + if (result == NULL) + return NULL; + block = BLOCK (result); + _heapinfo[block].busy.type = 0; + _heapinfo[block].busy.info.size = blocks; + ++_chunks_used; + _bytes_used += blocks * BLOCKSIZE; + return result; + } + } + + /* At this point we have found a suitable free list entry. + Figure out how to remove what we need from the list. */ + result = ADDRESS (block); + if (_heapinfo[block].free.size > blocks) + { + /* The block we found has a bit left over, + so relink the tail end back into the free list. */ + _heapinfo[block + blocks].free.size + = _heapinfo[block].free.size - blocks; + _heapinfo[block + blocks].free.next + = _heapinfo[block].free.next; + _heapinfo[block + blocks].free.prev + = _heapinfo[block].free.prev; + _heapinfo[_heapinfo[block].free.prev].free.next + = _heapinfo[_heapinfo[block].free.next].free.prev + = _heapindex = block + blocks; + } + else + { + /* The block exactly matches our requirements, + so just remove it from the list. */ + _heapinfo[_heapinfo[block].free.next].free.prev + = _heapinfo[block].free.prev; + _heapinfo[_heapinfo[block].free.prev].free.next + = _heapindex = _heapinfo[block].free.next; + --_chunks_free; + } + + _heapinfo[block].busy.type = 0; + _heapinfo[block].busy.info.size = blocks; + ++_chunks_used; + _bytes_used += blocks * BLOCKSIZE; + _bytes_free -= blocks * BLOCKSIZE; + + /* Mark all the blocks of the object just allocated except for the + first with a negative number so you can find the first block by + adding that adjustment. */ + while (--blocks > 0) + _heapinfo[block + blocks].busy.info.size = -blocks; + } + + return result; +} + +#ifndef _LIBC + +/* On some ANSI C systems, some libc functions call _malloc, _free + and _realloc. Make them use the GNU functions. */ + +__ptr_t +_malloc (size) + __malloc_size_t size; +{ + return malloc (size); +} + +void +_free (ptr) + __ptr_t ptr; +{ + free (ptr); +} + +__ptr_t +_realloc (ptr, size) + __ptr_t ptr; + __malloc_size_t size; +{ + return realloc (ptr, size); +} + +#endif +/* Free a block of memory allocated by `malloc'. + Copyright 1990, 1991, 1992, 1994 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +/* Debugging hook for free. */ +void (*__free_hook) __P ((__ptr_t __ptr)); + +/* List of blocks allocated by memalign. */ +struct alignlist *_aligned_blocks = NULL; + +/* Return memory to the heap. + Like `free' but don't call a __free_hook if there is one. */ +void +_free_internal (ptr) + __ptr_t ptr; +{ + int type; + __malloc_size_t block, blocks; + register __malloc_size_t i; + struct list *prev, *next; + + block = BLOCK (ptr); + + type = _heapinfo[block].busy.type; + switch (type) + { + case 0: + /* Get as many statistics as early as we can. */ + --_chunks_used; + _bytes_used -= _heapinfo[block].busy.info.size * BLOCKSIZE; + _bytes_free += _heapinfo[block].busy.info.size * BLOCKSIZE; + + /* Find the free cluster previous to this one in the free list. + Start searching at the last block referenced; this may benefit + programs with locality of allocation. */ + i = _heapindex; + if (i > block) + while (i > block) + i = _heapinfo[i].free.prev; + else + { + do + i = _heapinfo[i].free.next; + while (i > 0 && i < block); + i = _heapinfo[i].free.prev; + } + + /* Determine how to link this block into the free list. */ + if (block == i + _heapinfo[i].free.size) + { + /* Coalesce this block with its predecessor. */ + _heapinfo[i].free.size += _heapinfo[block].busy.info.size; + block = i; + } + else + { + /* Really link this block back into the free list. */ + _heapinfo[block].free.size = _heapinfo[block].busy.info.size; + _heapinfo[block].free.next = _heapinfo[i].free.next; + _heapinfo[block].free.prev = i; + _heapinfo[i].free.next = block; + _heapinfo[_heapinfo[block].free.next].free.prev = block; + ++_chunks_free; + } + + /* Now that the block is linked in, see if we can coalesce it + with its successor (by deleting its successor from the list + and adding in its size). */ + if (block + _heapinfo[block].free.size == _heapinfo[block].free.next) + { + _heapinfo[block].free.size + += _heapinfo[_heapinfo[block].free.next].free.size; + _heapinfo[block].free.next + = _heapinfo[_heapinfo[block].free.next].free.next; + _heapinfo[_heapinfo[block].free.next].free.prev = block; + --_chunks_free; + } + + /* Now see if we can return stuff to the system. */ + blocks = _heapinfo[block].free.size; + if (blocks >= FINAL_FREE_BLOCKS && block + blocks == _heaplimit + && (*__morecore) (0) == ADDRESS (block + blocks)) + { + register __malloc_size_t bytes = blocks * BLOCKSIZE; + _heaplimit -= blocks; + (*__morecore) (-bytes); + _heapinfo[_heapinfo[block].free.prev].free.next + = _heapinfo[block].free.next; + _heapinfo[_heapinfo[block].free.next].free.prev + = _heapinfo[block].free.prev; + block = _heapinfo[block].free.prev; + --_chunks_free; + _bytes_free -= bytes; + } + + /* Set the next search to begin at this block. */ + _heapindex = block; + break; + + default: + /* Do some of the statistics. */ + --_chunks_used; + _bytes_used -= 1 << type; + ++_chunks_free; + _bytes_free += 1 << type; + + /* Get the address of the first free fragment in this block. */ + prev = (struct list *) ((char *) ADDRESS (block) + + (_heapinfo[block].busy.info.frag.first << type)); + + if (_heapinfo[block].busy.info.frag.nfree == (BLOCKSIZE >> type) - 1) + { + /* If all fragments of this block are free, remove them + from the fragment list and free the whole block. */ + next = prev; + for (i = 1; i < (__malloc_size_t) (BLOCKSIZE >> type); ++i) + next = next->next; + prev->prev->next = next; + if (next != NULL) + next->prev = prev->prev; + _heapinfo[block].busy.type = 0; + _heapinfo[block].busy.info.size = 1; + + /* Keep the statistics accurate. */ + ++_chunks_used; + _bytes_used += BLOCKSIZE; + _chunks_free -= BLOCKSIZE >> type; + _bytes_free -= BLOCKSIZE; + + free (ADDRESS (block)); + } + else if (_heapinfo[block].busy.info.frag.nfree != 0) + { + /* If some fragments of this block are free, link this + fragment into the fragment list after the first free + fragment of this block. */ + next = (struct list *) ptr; + next->next = prev->next; + next->prev = prev; + prev->next = next; + if (next->next != NULL) + next->next->prev = next; + ++_heapinfo[block].busy.info.frag.nfree; + } + else + { + /* No fragments of this block are free, so link this + fragment into the fragment list and announce that + it is the first free fragment of this block. */ + prev = (struct list *) ptr; + _heapinfo[block].busy.info.frag.nfree = 1; + _heapinfo[block].busy.info.frag.first = (unsigned long int) + ((unsigned long int) ((char *) ptr - (char *) NULL) + % BLOCKSIZE >> type); + prev->next = _fraghead[type].next; + prev->prev = &_fraghead[type]; + prev->prev->next = prev; + if (prev->next != NULL) + prev->next->prev = prev; + } + break; + } +} + +/* Return memory to the heap. */ +void +free (ptr) + __ptr_t ptr; +{ + register struct alignlist *l; + + if (ptr == NULL) + return; + + for (l = _aligned_blocks; l != NULL; l = l->next) + if (l->aligned == ptr) + { + l->aligned = NULL; /* Mark the slot in the list as free. */ + ptr = l->exact; + break; + } + + if (__free_hook != NULL) + (*__free_hook) (ptr); + else + _free_internal (ptr); +} +/* Copyright (C) 1991, 1993, 1994 Free Software Foundation, Inc. +This file is part of the GNU C Library. + +The GNU C Library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +The GNU C Library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with the GNU C Library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +#ifdef _LIBC + +#include +#include + +#undef cfree + +function_alias(cfree, free, void, (ptr), + DEFUN(cfree, (ptr), PTR ptr)) + +#else + +void +cfree (ptr) + __ptr_t ptr; +{ + free (ptr); +} + +#endif +/* Change the size of a block allocated by `malloc'. + Copyright 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +#if (defined (MEMMOVE_MISSING) || \ + !defined(_LIBC) && !defined(STDC_HEADERS) && !defined(USG)) + +/* Snarfed directly from Emacs src/dispnew.c: + XXX Should use system bcopy if it handles overlap. */ +#ifndef emacs + +/* Like bcopy except never gets confused by overlap. */ + +static void +safe_bcopy (from, to, size) + char *from, *to; + int size; +{ + if (size <= 0 || from == to) + return; + + /* If the source and destination don't overlap, then bcopy can + handle it. If they do overlap, but the destination is lower in + memory than the source, we'll assume bcopy can handle that. */ + if (to < from || from + size <= to) + bcopy (from, to, size); + + /* Otherwise, we'll copy from the end. */ + else + { + register char *endf = from + size; + register char *endt = to + size; + + /* If TO - FROM is large, then we should break the copy into + nonoverlapping chunks of TO - FROM bytes each. However, if + TO - FROM is small, then the bcopy function call overhead + makes this not worth it. The crossover point could be about + anywhere. Since I don't think the obvious copy loop is too + bad, I'm trying to err in its favor. */ + if (to - from < 64) + { + do + *--endt = *--endf; + while (endf != from); + } + else + { + for (;;) + { + endt -= (to - from); + endf -= (to - from); + + if (endt < to) + break; + + bcopy (endf, endt, to - from); + } + + /* If SIZE wasn't a multiple of TO - FROM, there will be a + little left over. The amount left over is + (endt + (to - from)) - to, which is endt - from. */ + bcopy (from, to, endt - from); + } + } +} +#endif /* Not emacs. */ + +#define memmove(to, from, size) safe_bcopy ((from), (to), (size)) + +#endif + + +#define min(A, B) ((A) < (B) ? (A) : (B)) + +/* Debugging hook for realloc. */ +__ptr_t (*__realloc_hook) __P ((__ptr_t __ptr, __malloc_size_t __size)); + +/* Resize the given region to the new size, returning a pointer + to the (possibly moved) region. This is optimized for speed; + some benchmarks seem to indicate that greater compactness is + achieved by unconditionally allocating and copying to a + new region. This module has incestuous knowledge of the + internals of both free and malloc. */ +__ptr_t +realloc (ptr, size) + __ptr_t ptr; + __malloc_size_t size; +{ + __ptr_t result; + int type; + __malloc_size_t block, blocks, oldlimit; + + if (size == 0) + { + free (ptr); + return malloc (0); + } + else if (ptr == NULL) + return malloc (size); + + if (__realloc_hook != NULL) + return (*__realloc_hook) (ptr, size); + + block = BLOCK (ptr); + + type = _heapinfo[block].busy.type; + switch (type) + { + case 0: + /* Maybe reallocate a large block to a small fragment. */ + if (size <= BLOCKSIZE / 2) + { + result = malloc (size); + if (result != NULL) + { + memcpy (result, ptr, size); + _free_internal (ptr); + return result; + } + } + + /* The new size is a large allocation as well; + see if we can hold it in place. */ + blocks = BLOCKIFY (size); + if (blocks < _heapinfo[block].busy.info.size) + { + /* The new size is smaller; return + excess memory to the free list. */ + _heapinfo[block + blocks].busy.type = 0; + _heapinfo[block + blocks].busy.info.size + = _heapinfo[block].busy.info.size - blocks; + _heapinfo[block].busy.info.size = blocks; + /* We have just created a new chunk by splitting a chunk in two. + Now we will free this chunk; increment the statistics counter + so it doesn't become wrong when _free_internal decrements it. */ + ++_chunks_used; + _free_internal (ADDRESS (block + blocks)); + result = ptr; + } + else if (blocks == _heapinfo[block].busy.info.size) + /* No size change necessary. */ + result = ptr; + else + { + /* Won't fit, so allocate a new region that will. + Free the old region first in case there is sufficient + adjacent free space to grow without moving. */ + blocks = _heapinfo[block].busy.info.size; + /* Prevent free from actually returning memory to the system. */ + oldlimit = _heaplimit; + _heaplimit = 0; + _free_internal (ptr); + _heaplimit = oldlimit; + result = malloc (size); + if (result == NULL) + { + /* Now we're really in trouble. We have to unfree + the thing we just freed. Unfortunately it might + have been coalesced with its neighbors. */ + if (_heapindex == block) + (void) malloc (blocks * BLOCKSIZE); + else + { + __ptr_t previous = malloc ((block - _heapindex) * BLOCKSIZE); + (void) malloc (blocks * BLOCKSIZE); + _free_internal (previous); + } + return NULL; + } + if (ptr != result) + memmove (result, ptr, blocks * BLOCKSIZE); + } + break; + + default: + /* Old size is a fragment; type is logarithm + to base two of the fragment size. */ + if (size > (__malloc_size_t) (1 << (type - 1)) && + size <= (__malloc_size_t) (1 << type)) + /* The new size is the same kind of fragment. */ + result = ptr; + else + { + /* The new size is different; allocate a new space, + and copy the lesser of the new size and the old. */ + result = malloc (size); + if (result == NULL) + return NULL; + memcpy (result, ptr, min (size, (__malloc_size_t) 1 << type)); + free (ptr); + } + break; + } + + return result; +} +/* Copyright (C) 1991, 1992, 1994 Free Software Foundation, Inc. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +/* Allocate an array of NMEMB elements each SIZE bytes long. + The entire array is initialized to zeros. */ +__ptr_t +calloc (nmemb, size) + register __malloc_size_t nmemb; + register __malloc_size_t size; +{ + register __ptr_t result = malloc (nmemb * size); + + if (result != NULL) + (void) memset (result, 0, nmemb * size); + + return result; +} +/* Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc. +This file is part of the GNU C Library. + +The GNU C Library 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. + +The GNU C Library 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 the GNU C Library; see the file COPYING. If not, write to +the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +#ifndef __GNU_LIBRARY__ +#define __sbrk sbrk +#endif + +#ifdef __GNU_LIBRARY__ +/* It is best not to declare this and cast its result on foreign operating + systems with potentially hostile include files. */ +extern __ptr_t __sbrk __P ((int increment)); +#endif + +#ifndef NULL +#define NULL 0 +#endif + +/* Allocate INCREMENT more bytes of data space, + and return the start of data space, or NULL on errors. + If INCREMENT is negative, shrink data space. */ +__ptr_t +__default_morecore (increment) +#ifdef __STDC__ + ptrdiff_t increment; +#else + int increment; +#endif +{ + __ptr_t result = (__ptr_t) __sbrk ((int) increment); + if (result == (__ptr_t) -1) + return NULL; + return result; +} +/* Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +__ptr_t (*__memalign_hook) __P ((size_t __size, size_t __alignment)); + +__ptr_t +memalign (alignment, size) + __malloc_size_t alignment; + __malloc_size_t size; +{ + __ptr_t result; + unsigned long int adj; + + if (__memalign_hook) + return (*__memalign_hook) (alignment, size); + + size = ((size + alignment - 1) / alignment) * alignment; + + result = malloc (size); + if (result == NULL) + return NULL; + adj = (unsigned long int) ((unsigned long int) ((char *) result - + (char *) NULL)) % alignment; + if (adj != 0) + { + struct alignlist *l; + for (l = _aligned_blocks; l != NULL; l = l->next) + if (l->aligned == NULL) + /* This slot is free. Use it. */ + break; + if (l == NULL) + { + l = (struct alignlist *) malloc (sizeof (struct alignlist)); + if (l == NULL) + { + free (result); + return NULL; + } + l->next = _aligned_blocks; + _aligned_blocks = l; + } + l->exact = result; + result = l->aligned = (char *) result + alignment - adj; + } + + return result; +} diff --git a/malloc/malloc-find.c b/malloc/malloc-find.c new file mode 100644 index 0000000..47bb811 --- /dev/null +++ b/malloc/malloc-find.c @@ -0,0 +1,59 @@ +/* Find the starting address of a malloc'd block, from anywhere inside it. + Copyright (C) 1995 Free Software Foundation, Inc. + +This file is part of the GNU C Library. Its master source is NOT part of +the C library, however. The master source lives in /gd/gnu/lib. + +The GNU C Library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +The GNU C Library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with the GNU C Library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +/* Given an address in the middle of a malloc'd object, + return the address of the beginning of the object. */ + +__ptr_t +malloc_find_object_address (ptr) + __ptr_t ptr; +{ + __malloc_size_t block = BLOCK (ptr); + int type = _heapinfo[block].busy.type; + + if (type == 0) + { + /* The object is one or more entire blocks. */ + __malloc_ptrdiff_t sizevalue = _heapinfo[block].busy.info.size; + + if (sizevalue < 0) + /* This is one of the blocks after the first. SIZEVALUE + says how many blocks to go back to find the first. */ + block += sizevalue; + + /* BLOCK is now the first block of the object. + Its start is the start of the object. */ + return ADDRESS (block); + } + else + { + /* Get the size of fragments in this block. */ + __malloc_size_t size = 1 << type; + + /* Turn off the low bits to find the start address of the fragment. */ + return _heapbase + (((char *) ptr - _heapbase) & ~(size - 1)); + } +} diff --git a/malloc/malloc.c b/malloc/malloc.c new file mode 100644 index 0000000..088fd1f --- /dev/null +++ b/malloc/malloc.c @@ -0,0 +1,375 @@ +/* Memory allocator `malloc'. + Copyright 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +/* How to really get more memory. */ +__ptr_t (*__morecore) __P ((ptrdiff_t __size)) = __default_morecore; + +/* Debugging hook for `malloc'. */ +__ptr_t (*__malloc_hook) __P ((__malloc_size_t __size)); + +/* Pointer to the base of the first block. */ +char *_heapbase; + +/* Block information table. Allocated with align/__free (not malloc/free). */ +malloc_info *_heapinfo; + +/* Number of info entries. */ +static __malloc_size_t heapsize; + +/* Search index in the info table. */ +__malloc_size_t _heapindex; + +/* Limit of valid info table indices. */ +__malloc_size_t _heaplimit; + +/* Free lists for each fragment size. */ +struct list _fraghead[BLOCKLOG]; + +/* Instrumentation. */ +__malloc_size_t _chunks_used; +__malloc_size_t _bytes_used; +__malloc_size_t _chunks_free; +__malloc_size_t _bytes_free; + +/* Are you experienced? */ +int __malloc_initialized; + +void (*__malloc_initialize_hook) __P ((void)); +void (*__after_morecore_hook) __P ((void)); + +/* Aligned allocation. */ +static __ptr_t align __P ((__malloc_size_t)); +static __ptr_t +align (size) + __malloc_size_t size; +{ + __ptr_t result; + unsigned long int adj; + + result = (*__morecore) (size); + adj = (unsigned long int) ((unsigned long int) ((char *) result - + (char *) NULL)) % BLOCKSIZE; + if (adj != 0) + { + adj = BLOCKSIZE - adj; + (void) (*__morecore) (adj); + result = (char *) result + adj; + } + + if (__after_morecore_hook) + (*__after_morecore_hook) (); + + return result; +} + +/* Set everything up and remember that we have. */ +static int initialize __P ((void)); +static int +initialize () +{ + if (__malloc_initialize_hook) + (*__malloc_initialize_hook) (); + + heapsize = HEAP / BLOCKSIZE; + _heapinfo = (malloc_info *) align (heapsize * sizeof (malloc_info)); + if (_heapinfo == NULL) + return 0; + memset (_heapinfo, 0, heapsize * sizeof (malloc_info)); + _heapinfo[0].free.size = 0; + _heapinfo[0].free.next = _heapinfo[0].free.prev = 0; + _heapindex = 0; + _heapbase = (char *) _heapinfo; + + /* Account for the _heapinfo block itself in the statistics. */ + _bytes_used = heapsize * sizeof (malloc_info); + _chunks_used = 1; + + __malloc_initialized = 1; + return 1; +} + +/* Get neatly aligned memory, initializing or + growing the heap info table as necessary. */ +static __ptr_t morecore __P ((__malloc_size_t)); +static __ptr_t +morecore (size) + __malloc_size_t size; +{ + __ptr_t result; + malloc_info *newinfo, *oldinfo; + __malloc_size_t newsize; + + result = align (size); + if (result == NULL) + return NULL; + + /* Check if we need to grow the info table. */ + if ((__malloc_size_t) BLOCK ((char *) result + size) > heapsize) + { + newsize = heapsize; + while ((__malloc_size_t) BLOCK ((char *) result + size) > newsize) + newsize *= 2; + newinfo = (malloc_info *) align (newsize * sizeof (malloc_info)); + if (newinfo == NULL) + { + (*__morecore) (-size); + return NULL; + } + memcpy (newinfo, _heapinfo, heapsize * sizeof (malloc_info)); + memset (&newinfo[heapsize], 0, + (newsize - heapsize) * sizeof (malloc_info)); + oldinfo = _heapinfo; + newinfo[BLOCK (oldinfo)].busy.type = 0; + newinfo[BLOCK (oldinfo)].busy.info.size + = BLOCKIFY (heapsize * sizeof (malloc_info)); + _heapinfo = newinfo; + /* Account for the _heapinfo block itself in the statistics. */ + _bytes_used += newsize * sizeof (malloc_info); + ++_chunks_used; + _free_internal (oldinfo); + heapsize = newsize; + } + + _heaplimit = BLOCK ((char *) result + size); + return result; +} + +/* Allocate memory from the heap. */ +__ptr_t +malloc (size) + __malloc_size_t size; +{ + __ptr_t result; + __malloc_size_t block, blocks, lastblocks, start; + register __malloc_size_t i; + struct list *next; + + /* ANSI C allows `malloc (0)' to either return NULL, or to return a + valid address you can realloc and free (though not dereference). + + It turns out that some extant code (sunrpc, at least Ultrix's version) + expects `malloc (0)' to return non-NULL and breaks otherwise. + Be compatible. */ + +#if 0 + if (size == 0) + return NULL; +#endif + + if (__malloc_hook != NULL) + return (*__malloc_hook) (size); + + if (!__malloc_initialized) + if (!initialize ()) + return NULL; + + if (size < sizeof (struct list)) + size = sizeof (struct list); + +#ifdef SUNOS_LOCALTIME_BUG + if (size < 16) + size = 16; +#endif + + /* Determine the allocation policy based on the request size. */ + if (size <= BLOCKSIZE / 2) + { + /* Small allocation to receive a fragment of a block. + Determine the logarithm to base two of the fragment size. */ + register __malloc_size_t log = 1; + --size; + while ((size /= 2) != 0) + ++log; + + /* Look in the fragment lists for a + free fragment of the desired size. */ + next = _fraghead[log].next; + if (next != NULL) + { + /* There are free fragments of this size. + Pop a fragment out of the fragment list and return it. + Update the block's nfree and first counters. */ + result = (__ptr_t) next; + next->prev->next = next->next; + if (next->next != NULL) + next->next->prev = next->prev; + block = BLOCK (result); + if (--_heapinfo[block].busy.info.frag.nfree != 0) + _heapinfo[block].busy.info.frag.first = (unsigned long int) + ((unsigned long int) ((char *) next->next - (char *) NULL) + % BLOCKSIZE) >> log; + + /* Update the statistics. */ + ++_chunks_used; + _bytes_used += 1 << log; + --_chunks_free; + _bytes_free -= 1 << log; + } + else + { + /* No free fragments of the desired size, so get a new block + and break it into fragments, returning the first. */ + result = malloc (BLOCKSIZE); + if (result == NULL) + return NULL; + + /* Link all fragments but the first into the free list. */ + for (i = 1; i < (__malloc_size_t) (BLOCKSIZE >> log); ++i) + { + next = (struct list *) ((char *) result + (i << log)); + next->next = _fraghead[log].next; + next->prev = &_fraghead[log]; + next->prev->next = next; + if (next->next != NULL) + next->next->prev = next; + } + + /* Initialize the nfree and first counters for this block. */ + block = BLOCK (result); + _heapinfo[block].busy.type = log; + _heapinfo[block].busy.info.frag.nfree = i - 1; + _heapinfo[block].busy.info.frag.first = i - 1; + + _chunks_free += (BLOCKSIZE >> log) - 1; + _bytes_free += BLOCKSIZE - (1 << log); + _bytes_used -= BLOCKSIZE - (1 << log); + } + } + else + { + /* Large allocation to receive one or more blocks. + Search the free list in a circle starting at the last place visited. + If we loop completely around without finding a large enough + space we will have to get more memory from the system. */ + blocks = BLOCKIFY (size); + start = block = _heapindex; + while (_heapinfo[block].free.size < blocks) + { + block = _heapinfo[block].free.next; + if (block == start) + { + /* Need to get more from the system. Check to see if + the new core will be contiguous with the final free + block; if so we don't need to get as much. */ + block = _heapinfo[0].free.prev; + lastblocks = _heapinfo[block].free.size; + if (_heaplimit != 0 && block + lastblocks == _heaplimit && + (*__morecore) (0) == ADDRESS (block + lastblocks) && + (morecore ((blocks - lastblocks) * BLOCKSIZE)) != NULL) + { + /* Which block we are extending (the `final free + block' referred to above) might have changed, if + it got combined with a freed info table. */ + block = _heapinfo[0].free.prev; + _heapinfo[block].free.size += (blocks - lastblocks); + _bytes_free += (blocks - lastblocks) * BLOCKSIZE; + continue; + } + result = morecore (blocks * BLOCKSIZE); + if (result == NULL) + return NULL; + block = BLOCK (result); + _heapinfo[block].busy.type = 0; + _heapinfo[block].busy.info.size = blocks; + ++_chunks_used; + _bytes_used += blocks * BLOCKSIZE; + return result; + } + } + + /* At this point we have found a suitable free list entry. + Figure out how to remove what we need from the list. */ + result = ADDRESS (block); + if (_heapinfo[block].free.size > blocks) + { + /* The block we found has a bit left over, + so relink the tail end back into the free list. */ + _heapinfo[block + blocks].free.size + = _heapinfo[block].free.size - blocks; + _heapinfo[block + blocks].free.next + = _heapinfo[block].free.next; + _heapinfo[block + blocks].free.prev + = _heapinfo[block].free.prev; + _heapinfo[_heapinfo[block].free.prev].free.next + = _heapinfo[_heapinfo[block].free.next].free.prev + = _heapindex = block + blocks; + } + else + { + /* The block exactly matches our requirements, + so just remove it from the list. */ + _heapinfo[_heapinfo[block].free.next].free.prev + = _heapinfo[block].free.prev; + _heapinfo[_heapinfo[block].free.prev].free.next + = _heapindex = _heapinfo[block].free.next; + --_chunks_free; + } + + _heapinfo[block].busy.type = 0; + _heapinfo[block].busy.info.size = blocks; + ++_chunks_used; + _bytes_used += blocks * BLOCKSIZE; + _bytes_free -= blocks * BLOCKSIZE; + + /* Mark all the blocks of the object just allocated except for the + first with a negative number so you can find the first block by + adding that adjustment. */ + while (--blocks > 0) + _heapinfo[block + blocks].busy.info.size = -blocks; + } + + return result; +} + +#ifndef _LIBC + +/* On some ANSI C systems, some libc functions call _malloc, _free + and _realloc. Make them use the GNU functions. */ + +__ptr_t +_malloc (size) + __malloc_size_t size; +{ + return malloc (size); +} + +void +_free (ptr) + __ptr_t ptr; +{ + free (ptr); +} + +__ptr_t +_realloc (ptr, size) + __ptr_t ptr; + __malloc_size_t size; +{ + return realloc (ptr, size); +} + +#endif diff --git a/malloc/malloc.h b/malloc/malloc.h new file mode 100644 index 0000000..1b2365c --- /dev/null +++ b/malloc/malloc.h @@ -0,0 +1,294 @@ +/* Declarations for `malloc' and friends. + Copyright 1990, 1991, 1992, 1993, 1995 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef _MALLOC_H + +#define _MALLOC_H 1 + +#ifdef _MALLOC_INTERNAL + +#ifdef HAVE_CONFIG_H +#include +#endif + +#if defined(_LIBC) || defined(STDC_HEADERS) || defined(USG) +#include +#else +#ifndef memset +#define memset(s, zero, n) bzero ((s), (n)) +#endif +#ifndef memcpy +#define memcpy(d, s, n) bcopy ((s), (d), (n)) +#endif +#endif + +#if defined (__GNU_LIBRARY__) || (defined (__STDC__) && __STDC__) +#include +#else +#ifndef CHAR_BIT +#define CHAR_BIT 8 +#endif +#endif + +#ifdef HAVE_UNISTD_H +#include +#endif + +#endif /* _MALLOC_INTERNAL. */ + + +#ifdef __cplusplus +extern "C" +{ +#endif + +#if defined (__cplusplus) || (defined (__STDC__) && __STDC__) +#undef __P +#define __P(args) args +#undef __ptr_t +#define __ptr_t void * +#else /* Not C++ or ANSI C. */ +#undef __P +#define __P(args) () +#undef const +#define const +#undef __ptr_t +#define __ptr_t char * +#endif /* C++ or ANSI C. */ + +#if defined (__STDC__) && __STDC__ +#include +#define __malloc_size_t size_t +#define __malloc_ptrdiff_t ptrdiff_t +#else +#define __malloc_size_t unsigned int +#define __malloc_ptrdiff_t int +#endif + +#ifndef NULL +#define NULL 0 +#endif + + +/* Allocate SIZE bytes of memory. */ +extern __ptr_t malloc __P ((__malloc_size_t __size)); +/* Re-allocate the previously allocated block + in __ptr_t, making the new block SIZE bytes long. */ +extern __ptr_t realloc __P ((__ptr_t __ptr, __malloc_size_t __size)); +/* Allocate NMEMB elements of SIZE bytes each, all initialized to 0. */ +extern __ptr_t calloc __P ((__malloc_size_t __nmemb, __malloc_size_t __size)); +/* Free a block allocated by `malloc', `realloc' or `calloc'. */ +extern void free __P ((__ptr_t __ptr)); + +/* Allocate SIZE bytes allocated to ALIGNMENT bytes. */ +extern __ptr_t memalign __P ((__malloc_size_t __alignment, + __malloc_size_t __size)); + +/* Allocate SIZE bytes on a page boundary. */ +extern __ptr_t valloc __P ((__malloc_size_t __size)); + + +#ifdef _MALLOC_INTERNAL + +/* The allocator divides the heap into blocks of fixed size; large + requests receive one or more whole blocks, and small requests + receive a fragment of a block. Fragment sizes are powers of two, + and all fragments of a block are the same size. When all the + fragments in a block have been freed, the block itself is freed. */ +#define INT_BIT (CHAR_BIT * sizeof(int)) +#define BLOCKLOG (INT_BIT > 16 ? 12 : 9) +#define BLOCKSIZE (1 << BLOCKLOG) +#define BLOCKIFY(SIZE) (((SIZE) + BLOCKSIZE - 1) / BLOCKSIZE) + +/* Determine the amount of memory spanned by the initial heap table + (not an absolute limit). */ +#define HEAP (INT_BIT > 16 ? 4194304 : 65536) + +/* Number of contiguous free blocks allowed to build up at the end of + memory before they will be returned to the system. */ +#define FINAL_FREE_BLOCKS 8 + +/* Data structure giving per-block information. */ +typedef union + { + /* Heap information for a busy block. */ + struct + { + /* Zero for a large (multiblock) object, or positive giving the + logarithm to the base two of the fragment size. */ + int type; + union + { + struct + { + __malloc_size_t nfree; /* Free frags in a fragmented block. */ + __malloc_size_t first; /* First free fragment of the block. */ + } frag; + /* For a large object, in its first block, this has the number + of blocks in the object. In the other blocks, this has a + negative number which says how far back the first block is. */ + __malloc_ptrdiff_t size; + } info; + } busy; + /* Heap information for a free block + (that may be the first of a free cluster). */ + struct + { + __malloc_size_t size; /* Size (in blocks) of a free cluster. */ + __malloc_size_t next; /* Index of next free cluster. */ + __malloc_size_t prev; /* Index of previous free cluster. */ + } free; + } malloc_info; + +/* Pointer to first block of the heap. */ +extern char *_heapbase; + +/* Table indexed by block number giving per-block information. */ +extern malloc_info *_heapinfo; + +/* Address to block number and vice versa. */ +#define BLOCK(A) (((char *) (A) - _heapbase) / BLOCKSIZE + 1) +#define ADDRESS(B) ((__ptr_t) (((B) - 1) * BLOCKSIZE + _heapbase)) + +/* Current search index for the heap table. */ +extern __malloc_size_t _heapindex; + +/* Limit of valid info table indices. */ +extern __malloc_size_t _heaplimit; + +/* Doubly linked lists of free fragments. */ +struct list + { + struct list *next; + struct list *prev; + }; + +/* Free list headers for each fragment size. */ +extern struct list _fraghead[]; + +/* List of blocks allocated with `memalign' (or `valloc'). */ +struct alignlist + { + struct alignlist *next; + __ptr_t aligned; /* The address that memaligned returned. */ + __ptr_t exact; /* The address that malloc returned. */ + }; +extern struct alignlist *_aligned_blocks; + +/* Instrumentation. */ +extern __malloc_size_t _chunks_used; +extern __malloc_size_t _bytes_used; +extern __malloc_size_t _chunks_free; +extern __malloc_size_t _bytes_free; + +/* Internal version of `free' used in `morecore' (malloc.c). */ +extern void _free_internal __P ((__ptr_t __ptr)); + +#endif /* _MALLOC_INTERNAL. */ + +/* Given an address in the middle of a malloc'd object, + return the address of the beginning of the object. */ +extern __ptr_t malloc_find_object_address __P ((__ptr_t __ptr)); + +/* Underlying allocation function; successive calls should + return contiguous pieces of memory. */ +extern __ptr_t (*__morecore) __P ((__malloc_ptrdiff_t __size)); + +/* Default value of `__morecore'. */ +extern __ptr_t __default_morecore __P ((__malloc_ptrdiff_t __size)); + +/* If not NULL, this function is called after each time + `__morecore' is called to increase the data size. */ +extern void (*__after_morecore_hook) __P ((void)); + +/* Nonzero if `malloc' has been called and done its initialization. */ +extern int __malloc_initialized; + +/* Hooks for debugging versions. */ +extern void (*__malloc_initialize_hook) __P ((void)); +extern void (*__free_hook) __P ((__ptr_t __ptr)); +extern __ptr_t (*__malloc_hook) __P ((__malloc_size_t __size)); +extern __ptr_t (*__realloc_hook) __P ((__ptr_t __ptr, __malloc_size_t __size)); +extern __ptr_t (*__memalign_hook) __P ((__malloc_size_t __size, + __malloc_size_t __alignment)); + +/* Return values for `mprobe': these are the kinds of inconsistencies that + `mcheck' enables detection of. */ +enum mcheck_status + { + MCHECK_DISABLED = -1, /* Consistency checking is not turned on. */ + MCHECK_OK, /* Block is fine. */ + MCHECK_FREE, /* Block freed twice. */ + MCHECK_HEAD, /* Memory before the block was clobbered. */ + MCHECK_TAIL /* Memory after the block was clobbered. */ + }; + +/* Activate a standard collection of debugging hooks. This must be called + before `malloc' is ever called. ABORTFUNC is called with an error code + (see enum above) when an inconsistency is detected. If ABORTFUNC is + null, the standard function prints on stderr and then calls `abort'. */ +extern int mcheck __P ((void (*__abortfunc) __P ((enum mcheck_status)))); + +/* Check for aberrations in a particular malloc'd block. You must have + called `mcheck' already. These are the same checks that `mcheck' does + when you free or reallocate a block. */ +extern enum mcheck_status mprobe __P ((__ptr_t __ptr)); + +/* Activate a standard collection of tracing hooks. */ +extern void mtrace __P ((void)); +extern void muntrace __P ((void)); + +/* Statistics available to the user. */ +struct mstats + { + __malloc_size_t bytes_total; /* Total size of the heap. */ + __malloc_size_t chunks_used; /* Chunks allocated by the user. */ + __malloc_size_t bytes_used; /* Byte total of user-allocated chunks. */ + __malloc_size_t chunks_free; /* Chunks in the free list. */ + __malloc_size_t bytes_free; /* Byte total of chunks in the free list. */ + }; + +/* Pick up the current statistics. */ +extern struct mstats mstats __P ((void)); + +/* Call WARNFUN with a warning message when memory usage is high. */ +extern void memory_warnings __P ((__ptr_t __start, + void (*__warnfun) __P ((const char *)))); + + +/* Relocating allocator. */ + +/* Allocate SIZE bytes, and store the address in *HANDLEPTR. */ +extern __ptr_t r_alloc __P ((__ptr_t *__handleptr, __malloc_size_t __size)); + +/* Free the storage allocated in HANDLEPTR. */ +extern void r_alloc_free __P ((__ptr_t *__handleptr)); + +/* Adjust the block at HANDLEPTR to be SIZE bytes long. */ +extern __ptr_t r_re_alloc __P ((__ptr_t *__handleptr, __malloc_size_t __size)); + + +#ifdef __cplusplus +} +#endif + +#endif /* malloc.h */ diff --git a/malloc/mcheck.c b/malloc/mcheck.c new file mode 100644 index 0000000..437e145 --- /dev/null +++ b/malloc/mcheck.c @@ -0,0 +1,215 @@ +/* Standard debugging hooks for `malloc'. + Copyright 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#include +#endif + +/* Old hook values. */ +static void (*old_free_hook) __P ((__ptr_t ptr)); +static __ptr_t (*old_malloc_hook) __P ((__malloc_size_t size)); +static __ptr_t (*old_realloc_hook) __P ((__ptr_t ptr, __malloc_size_t size)); + +/* Function to call when something awful happens. */ +static void (*abortfunc) __P ((enum mcheck_status)); + +/* Arbitrary magical numbers. */ +#define MAGICWORD 0xfedabeeb +#define MAGICFREE 0xd8675309 +#define MAGICBYTE ((char) 0xd7) +#define MALLOCFLOOD ((char) 0x93) +#define FREEFLOOD ((char) 0x95) + +struct hdr + { + __malloc_size_t size; /* Exact size requested by user. */ + unsigned long int magic; /* Magic number to check header integrity. */ + }; + +#if defined(_LIBC) || defined(STDC_HEADERS) || defined(USG) +#define flood memset +#else +static void flood __P ((__ptr_t, int, __malloc_size_t)); +static void +flood (ptr, val, size) + __ptr_t ptr; + int val; + __malloc_size_t size; +{ + char *cp = ptr; + while (size--) + *cp++ = val; +} +#endif + +static enum mcheck_status checkhdr __P ((const struct hdr *)); +static enum mcheck_status +checkhdr (hdr) + const struct hdr *hdr; +{ + enum mcheck_status status; + switch (hdr->magic) + { + default: + status = MCHECK_HEAD; + break; + case MAGICFREE: + status = MCHECK_FREE; + break; + case MAGICWORD: + if (((char *) &hdr[1])[hdr->size] != MAGICBYTE) + status = MCHECK_TAIL; + else + status = MCHECK_OK; + break; + } + if (status != MCHECK_OK) + (*abortfunc) (status); + return status; +} + +static void freehook __P ((__ptr_t)); +static void +freehook (ptr) + __ptr_t ptr; +{ + struct hdr *hdr = ((struct hdr *) ptr) - 1; + checkhdr (hdr); + hdr->magic = MAGICFREE; + flood (ptr, FREEFLOOD, hdr->size); + __free_hook = old_free_hook; + free (hdr); + __free_hook = freehook; +} + +static __ptr_t mallochook __P ((__malloc_size_t)); +static __ptr_t +mallochook (size) + __malloc_size_t size; +{ + struct hdr *hdr; + + __malloc_hook = old_malloc_hook; + hdr = (struct hdr *) malloc (sizeof (struct hdr) + size + 1); + __malloc_hook = mallochook; + if (hdr == NULL) + return NULL; + + hdr->size = size; + hdr->magic = MAGICWORD; + ((char *) &hdr[1])[size] = MAGICBYTE; + flood ((__ptr_t) (hdr + 1), MALLOCFLOOD, size); + return (__ptr_t) (hdr + 1); +} + +static __ptr_t reallochook __P ((__ptr_t, __malloc_size_t)); +static __ptr_t +reallochook (ptr, size) + __ptr_t ptr; + __malloc_size_t size; +{ + struct hdr *hdr = ((struct hdr *) ptr) - 1; + __malloc_size_t osize = hdr->size; + + checkhdr (hdr); + if (size < osize) + flood ((char *) ptr + size, FREEFLOOD, osize - size); + __free_hook = old_free_hook; + __malloc_hook = old_malloc_hook; + __realloc_hook = old_realloc_hook; + hdr = (struct hdr *) realloc ((__ptr_t) hdr, sizeof (struct hdr) + size + 1); + __free_hook = freehook; + __malloc_hook = mallochook; + __realloc_hook = reallochook; + if (hdr == NULL) + return NULL; + + hdr->size = size; + hdr->magic = MAGICWORD; + ((char *) &hdr[1])[size] = MAGICBYTE; + if (size > osize) + flood ((char *) (hdr + 1) + osize, MALLOCFLOOD, size - osize); + return (__ptr_t) (hdr + 1); +} + +static void +mabort (status) + enum mcheck_status status; +{ + const char *msg; + switch (status) + { + case MCHECK_OK: + msg = "memory is consistent, library is buggy"; + break; + case MCHECK_HEAD: + msg = "memory clobbered before allocated block"; + break; + case MCHECK_TAIL: + msg = "memory clobbered past end of allocated block"; + break; + case MCHECK_FREE: + msg = "block freed twice"; + break; + default: + msg = "bogus mcheck_status, library is buggy"; + break; + } +#ifdef __GNU_LIBRARY__ + __libc_fatal (msg); +#else + fprintf (stderr, "mcheck: %s\n", msg); + fflush (stderr); + abort (); +#endif +} + +static int mcheck_used = 0; + +int +mcheck (func) + void (*func) __P ((enum mcheck_status)); +{ + abortfunc = (func != NULL) ? func : &mabort; + + /* These hooks may not be safely inserted if malloc is already in use. */ + if (!__malloc_initialized && !mcheck_used) + { + old_free_hook = __free_hook; + __free_hook = freehook; + old_malloc_hook = __malloc_hook; + __malloc_hook = mallochook; + old_realloc_hook = __realloc_hook; + __realloc_hook = reallochook; + mcheck_used = 1; + } + + return mcheck_used ? 0 : -1; +} + +enum mcheck_status +mprobe (__ptr_t ptr) +{ + return mcheck_used ? checkhdr (ptr) : MCHECK_DISABLED; +} diff --git a/malloc/mem-limits.h b/malloc/mem-limits.h new file mode 100644 index 0000000..0f3c382 --- /dev/null +++ b/malloc/mem-limits.h @@ -0,0 +1,184 @@ +/* Includes for memory limit warnings. + Copyright (C) 1990, 1993, 1994 Free Software Foundation, Inc. + + +This file is part of the GNU C Library. Its master source is NOT part of +the C library, however. The master source lives in /gd/gnu/lib. + +The GNU C Library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +The GNU C Library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with the GNU C Library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. */ + +#ifdef MSDOS +#include +#endif + +/* Some systems need this before . */ +#include + +#ifdef _LIBC + +#include +#define BSD4_2 /* Tell code below to use getrlimit. */ + +#else + +#if defined (__osf__) && (defined (__mips) || defined (mips) || defined(__alpha)) +#include +#include +#endif + +#ifdef __bsdi__ +#define BSD4_2 +#endif + +#ifndef BSD4_2 +#ifndef USG +#ifndef MSDOS +#ifndef WINDOWSNT +#include +#endif /* not WINDOWSNT */ +#endif /* not MSDOS */ +#endif /* not USG */ +#else /* if BSD4_2 */ +#include +#include +#endif /* BSD4_2 */ + +#endif /* _LIBC */ + +#ifdef emacs +/* The important properties of this type are that 1) it's a pointer, and + 2) arithmetic on it should work as if the size of the object pointed + to has a size of 1. */ +#ifdef __STDC__ +typedef void *POINTER; +#else +typedef char *POINTER; +#endif + +typedef unsigned long SIZE; + +#ifdef NULL +#undef NULL +#endif +#define NULL ((POINTER) 0) + +extern POINTER start_of_data (); +#ifdef DATA_SEG_BITS +#define EXCEEDS_LISP_PTR(ptr) \ + (((EMACS_UINT) (ptr) & ~DATA_SEG_BITS) >> VALBITS) +#else +#define EXCEEDS_LISP_PTR(ptr) ((EMACS_UINT) (ptr) >> VALBITS) +#endif + +#ifdef BSD +#ifndef DATA_SEG_BITS +extern char etext; +#define start_of_data() &etext +#endif +#endif + +#else /* Not emacs */ +extern char etext; +#define start_of_data() &etext +#endif /* Not emacs */ + + + +/* start of data space; can be changed by calling malloc_init */ +static POINTER data_space_start; + +/* Number of bytes of writable memory we can expect to be able to get */ +static unsigned int lim_data; + +#ifdef NO_LIM_DATA +static void +get_lim_data () +{ + lim_data = -1; +} +#else /* not NO_LIM_DATA */ + +#ifdef USG + +static void +get_lim_data () +{ + extern long ulimit (); + + lim_data = -1; + + /* Use the ulimit call, if we seem to have it. */ +#if !defined (ULIMIT_BREAK_VALUE) || defined (LINUX) + lim_data = ulimit (3, 0); +#endif + + /* If that didn't work, just use the macro's value. */ +#ifdef ULIMIT_BREAK_VALUE + if (lim_data == -1) + lim_data = ULIMIT_BREAK_VALUE; +#endif + + lim_data -= (long) data_space_start; +} + +#else /* not USG */ +#ifdef WINDOWSNT + +static void +get_lim_data () +{ + extern unsigned long data_region_size; + lim_data = data_region_size; +} + +#else +#if !defined (BSD4_2) && !defined (__osf__) + +#ifdef MSDOS +void +get_lim_data () +{ + _go32_dpmi_meminfo info; + + _go32_dpmi_get_free_memory_information (&info); + lim_data = info.available_memory; +} +#else /* not MSDOS */ +static void +get_lim_data () +{ + lim_data = vlimit (LIM_DATA, -1); +} +#endif /* not MSDOS */ + +#else /* BSD4_2 */ + +static void +get_lim_data () +{ + struct rlimit XXrlimit; + + getrlimit (RLIMIT_DATA, &XXrlimit); +#ifdef RLIM_INFINITY + lim_data = XXrlimit.rlim_cur & RLIM_INFINITY; /* soft limit */ +#else + lim_data = XXrlimit.rlim_cur; /* soft limit */ +#endif +} +#endif /* BSD4_2 */ +#endif /* not WINDOWSNT */ +#endif /* not USG */ +#endif /* not NO_LIM_DATA */ diff --git a/malloc/memalign.c b/malloc/memalign.c new file mode 100644 index 0000000..b306d04 --- /dev/null +++ b/malloc/memalign.c @@ -0,0 +1,66 @@ +/* Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +__ptr_t (*__memalign_hook) __P ((size_t __size, size_t __alignment)); + +__ptr_t +memalign (alignment, size) + __malloc_size_t alignment; + __malloc_size_t size; +{ + __ptr_t result; + unsigned long int adj; + + if (__memalign_hook) + return (*__memalign_hook) (alignment, size); + + size = ((size + alignment - 1) / alignment) * alignment; + + result = malloc (size); + if (result == NULL) + return NULL; + adj = (unsigned long int) ((unsigned long int) ((char *) result - + (char *) NULL)) % alignment; + if (adj != 0) + { + struct alignlist *l; + for (l = _aligned_blocks; l != NULL; l = l->next) + if (l->aligned == NULL) + /* This slot is free. Use it. */ + break; + if (l == NULL) + { + l = (struct alignlist *) malloc (sizeof (struct alignlist)); + if (l == NULL) + { + free (result); + return NULL; + } + l->next = _aligned_blocks; + _aligned_blocks = l; + } + l->exact = result; + result = l->aligned = (char *) result + alignment - adj; + } + + return result; +} diff --git a/malloc/morecore.c b/malloc/morecore.c new file mode 100644 index 0000000..5654a6d --- /dev/null +++ b/malloc/morecore.c @@ -0,0 +1,52 @@ +/* Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc. +This file is part of the GNU C Library. + +The GNU C Library 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. + +The GNU C Library 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 the GNU C Library; see the file COPYING. If not, write to +the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +#ifndef __GNU_LIBRARY__ +#define __sbrk sbrk +#endif + +#ifdef __GNU_LIBRARY__ +/* It is best not to declare this and cast its result on foreign operating + systems with potentially hostile include files. */ +extern __ptr_t __sbrk __P ((int increment)); +#endif + +#ifndef NULL +#define NULL 0 +#endif + +/* Allocate INCREMENT more bytes of data space, + and return the start of data space, or NULL on errors. + If INCREMENT is negative, shrink data space. */ +__ptr_t +__default_morecore (increment) +#ifdef __STDC__ + ptrdiff_t increment; +#else + int increment; +#endif +{ + __ptr_t result = (__ptr_t) __sbrk ((int) increment); + if (result == (__ptr_t) -1) + return NULL; + return result; +} diff --git a/malloc/mstats.c b/malloc/mstats.c new file mode 100644 index 0000000..7e946b2 --- /dev/null +++ b/malloc/mstats.c @@ -0,0 +1,39 @@ +/* Access the statistics maintained by `malloc'. + Copyright 1990, 1991, 1992 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +struct mstats +mstats () +{ + struct mstats result; + + result.bytes_total = (char *) (*__morecore) (0) - _heapbase; + result.chunks_used = _chunks_used; + result.bytes_used = _bytes_used; + result.chunks_free = _chunks_free; + result.bytes_free = _bytes_free; + return result; +} diff --git a/malloc/mtrace.awk b/malloc/mtrace.awk new file mode 100644 index 0000000..06844d1 --- /dev/null +++ b/malloc/mtrace.awk @@ -0,0 +1,50 @@ +# +# Awk program to analyze mtrace.c output. +# +{ + if ($1 == "@") { + where = " (" $2 ")" + n = 3 + } else { + where = "" + n = 1 + } + if ($n == "+") { + if (allocated[$(n+1)] != "") + print "+", $(n+1), "Alloc", NR, "duplicate:", allocated[$(n+1)], wherewas[$(n+1)], where; + else { + wherewas[$(n+1)] = where; + allocated[$(n+1)] = $(n+2); + } + } else if ($n == "-") { + if (allocated[$(n+1)] != "") { + wherewas[$(n+1)] = ""; + allocated[$(n+1)] = ""; + if (allocated[$(n+1)] != "") + print "DELETE FAILED", $(n+1), allocated[$(n+1)]; + } else + print "-", $(n+1), "Free", NR, "was never alloc'd", where; + } else if ($n == "<") { + if (allocated[$(n+1)] != "") { + wherewas[$(n+1)] = ""; + allocated[$(n+1)] = ""; + } else + print "-", $(n+1), "Realloc", NR, "was never alloc'd", where; + } else if ($n == ">") { + if (allocated[$(n+1)] != "") + print "+", $(n+1), "Realloc", NR, "duplicate:", allocated[$(n+1)], where; + else { + wherewas[$(n+1)] = $(n+2); + allocated[$(n+1)] = $(n+2); + } + } else if ($n == "=") { + # Ignore "= Start" + } else if ($n == "!") { + # Ignore failed realloc attempts for now + } +} +END { + for (x in allocated) + if (allocated[x] != "") + print "+", x, allocated[x], wherewas[x]; +} diff --git a/malloc/mtrace.c b/malloc/mtrace.c new file mode 100644 index 0000000..3d27ab0 --- /dev/null +++ b/malloc/mtrace.c @@ -0,0 +1,187 @@ +/* More debugging hooks for `malloc'. + Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc. + Written April 2, 1991 by John Gilmore of Cygnus Support. + Based on mcheck.c by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +#include + +#ifndef __GNU_LIBRARY__ +extern char *getenv (); +#else +#include +#endif + +static FILE *mallstream; +static char mallenv[]= "MALLOC_TRACE"; +static char mallbuf[BUFSIZ]; /* Buffer for the output. */ + +/* Address to breakpoint on accesses to... */ +__ptr_t mallwatch; + +/* File name and line number information, for callers that had + the foresight to call through a macro. */ +char *_mtrace_file; +int _mtrace_line; + +/* Old hook values. */ +static void (*tr_old_free_hook) __P ((__ptr_t ptr)); +static __ptr_t (*tr_old_malloc_hook) __P ((__malloc_size_t size)); +static __ptr_t (*tr_old_realloc_hook) __P ((__ptr_t ptr, __malloc_size_t size)); + +/* This function is called when the block being alloc'd, realloc'd, or + freed has an address matching the variable "mallwatch". In a debugger, + set "mallwatch" to the address of interest, then put a breakpoint on + tr_break. */ + +void tr_break __P ((void)); +void +tr_break () +{ +} + +static void tr_where __P ((void)); +static void +tr_where () +{ + if (_mtrace_file) + { + fprintf (mallstream, "@ %s:%d ", _mtrace_file, _mtrace_line); + _mtrace_file = NULL; + } +} + +static void tr_freehook __P ((__ptr_t)); +static void +tr_freehook (ptr) + __ptr_t ptr; +{ + tr_where (); + fprintf (mallstream, "- %p\n", ptr); /* Be sure to print it first. */ + if (ptr == mallwatch) + tr_break (); + __free_hook = tr_old_free_hook; + free (ptr); + __free_hook = tr_freehook; +} + +static __ptr_t tr_mallochook __P ((__malloc_size_t)); +static __ptr_t +tr_mallochook (size) + __malloc_size_t size; +{ + __ptr_t hdr; + + __malloc_hook = tr_old_malloc_hook; + hdr = (__ptr_t) malloc (size); + __malloc_hook = tr_mallochook; + + tr_where (); + /* We could be printing a NULL here; that's OK. */ + fprintf (mallstream, "+ %p %lx\n", hdr, (unsigned long)size); + + if (hdr == mallwatch) + tr_break (); + + return hdr; +} + +static __ptr_t tr_reallochook __P ((__ptr_t, __malloc_size_t)); +static __ptr_t +tr_reallochook (ptr, size) + __ptr_t ptr; + __malloc_size_t size; +{ + __ptr_t hdr; + + if (ptr == mallwatch) + tr_break (); + + __free_hook = tr_old_free_hook; + __malloc_hook = tr_old_malloc_hook; + __realloc_hook = tr_old_realloc_hook; + hdr = (__ptr_t) realloc (ptr, size); + __free_hook = tr_freehook; + __malloc_hook = tr_mallochook; + __realloc_hook = tr_reallochook; + tr_where (); + if (hdr == NULL) + /* Failed realloc. */ + fprintf (mallstream, "! %p %lx\n", ptr, (unsigned long)size); + else + fprintf (mallstream, "< %p\n> %p %lx\n", ptr, hdr, (unsigned long)size); + + if (hdr == mallwatch) + tr_break (); + + return hdr; +} + +/* We enable tracing if either the environment variable MALLOC_TRACE + is set, or if the variable mallwatch has been patched to an address + that the debugging user wants us to stop on. When patching mallwatch, + don't forget to set a breakpoint on tr_break! */ + +void +mtrace () +{ + char *mallfile; + + /* Don't panic if we're called more than once. */ + if (mallstream != NULL) + return; + + mallfile = getenv (mallenv); + if (mallfile != NULL || mallwatch != NULL) + { + mallstream = fopen (mallfile != NULL ? mallfile : "/dev/null", "w"); + if (mallstream != NULL) + { + /* Be sure it doesn't malloc its buffer! */ + setbuf (mallstream, mallbuf); + fprintf (mallstream, "= Start\n"); + tr_old_free_hook = __free_hook; + __free_hook = tr_freehook; + tr_old_malloc_hook = __malloc_hook; + __malloc_hook = tr_mallochook; + tr_old_realloc_hook = __realloc_hook; + __realloc_hook = tr_reallochook; + } + } +} + +void +muntrace () +{ + if (mallstream == NULL) + return; + + fprintf (mallstream, "= End\n"); + fclose (mallstream); + mallstream = NULL; + __free_hook = tr_old_free_hook; + __malloc_hook = tr_old_malloc_hook; + __realloc_hook = tr_old_realloc_hook; +} diff --git a/malloc/ralloc.c b/malloc/ralloc.c new file mode 100644 index 0000000..602522e --- /dev/null +++ b/malloc/ralloc.c @@ -0,0 +1,1086 @@ +/* Block-relocating memory allocator. + Copyright (C) 1993, 1995 Free Software Foundation, Inc. + + +This file is part of the GNU C Library. Its master source is NOT part of +the C library, however. The master source lives in /gd/gnu/lib. + +The GNU C Library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +The GNU C Library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with the GNU C Library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. */ + +/* NOTES: + + Only relocate the blocs necessary for SIZE in r_alloc_sbrk, + rather than all of them. This means allowing for a possible + hole between the first bloc and the end of malloc storage. */ + +#ifdef emacs + +#include +#include "lisp.h" /* Needed for VALBITS. */ + +#undef NULL + +/* The important properties of this type are that 1) it's a pointer, and + 2) arithmetic on it should work as if the size of the object pointed + to has a size of 1. */ +#if 0 /* Arithmetic on void* is a GCC extension. */ +#ifdef __STDC__ +typedef void *POINTER; +#else + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif + +typedef char *POINTER; + +#endif +#endif /* 0 */ + +/* Unconditionally use char * for this. */ +typedef char *POINTER; + +typedef unsigned long SIZE; + +/* Declared in dispnew.c, this version doesn't screw up if regions + overlap. */ +extern void safe_bcopy (); + +#include "getpagesize.h" + +#else /* Not emacs. */ + +#include + +typedef size_t SIZE; +typedef void *POINTER; + +#include +#include +#include + +#define safe_bcopy(x, y, z) memmove (y, x, z) + +#endif /* emacs. */ + +#define NIL ((POINTER) 0) + +/* A flag to indicate whether we have initialized ralloc yet. For + Emacs's sake, please do not make this local to malloc_init; on some + machines, the dumping procedure makes all static variables + read-only. On these machines, the word static is #defined to be + the empty string, meaning that r_alloc_initialized becomes an + automatic variable, and loses its value each time Emacs is started up. */ +static int r_alloc_initialized = 0; + +static void r_alloc_init (); + +/* Declarations for working with the malloc, ralloc, and system breaks. */ + +/* Function to set the real break value. */ +static POINTER (*real_morecore) (); + +/* The break value, as seen by malloc. */ +static POINTER virtual_break_value; + +/* The address of the end of the last data in use by ralloc, + including relocatable blocs as well as malloc data. */ +static POINTER break_value; + +/* This is the size of a page. We round memory requests to this boundary. */ +static int page_size; + +/* Whenever we get memory from the system, get this many extra bytes. This + must be a multiple of page_size. */ +static int extra_bytes; + +/* Macros for rounding. Note that rounding to any value is possible + by changing the definition of PAGE. */ +#define PAGE (getpagesize ()) +#define ALIGNED(addr) (((unsigned long int) (addr) & (page_size - 1)) == 0) +#define ROUNDUP(size) (((unsigned long int) (size) + page_size - 1) \ + & ~(page_size - 1)) +#define ROUND_TO_PAGE(addr) (addr & (~(page_size - 1))) + +#define MEM_ALIGN sizeof(double) +#define MEM_ROUNDUP(addr) (((unsigned long int)(addr) + MEM_ALIGN - 1) \ + & ~(MEM_ALIGN - 1)) + +/* Data structures of heaps and blocs. */ + +/* The relocatable objects, or blocs, and the malloc data + both reside within one or more heaps. + Each heap contains malloc data, running from `start' to `bloc_start', + and relocatable objects, running from `bloc_start' to `free'. + + Relocatable objects may relocate within the same heap + or may move into another heap; the heaps themselves may grow + but they never move. + + We try to make just one heap and make it larger as necessary. + But sometimes we can't do that, because we can't get continguous + space to add onto the heap. When that happens, we start a new heap. */ + +typedef struct heap +{ + struct heap *next; + struct heap *prev; + /* Start of memory range of this heap. */ + POINTER start; + /* End of memory range of this heap. */ + POINTER end; + /* Start of relocatable data in this heap. */ + POINTER bloc_start; + /* Start of unused space in this heap. */ + POINTER free; + /* First bloc in this heap. */ + struct bp *first_bloc; + /* Last bloc in this heap. */ + struct bp *last_bloc; +} *heap_ptr; + +#define NIL_HEAP ((heap_ptr) 0) +#define HEAP_PTR_SIZE (sizeof (struct heap)) + +/* This is the first heap object. + If we need additional heap objects, each one resides at the beginning of + the space it covers. */ +static struct heap heap_base; + +/* Head and tail of the list of heaps. */ +static heap_ptr first_heap, last_heap; + +/* These structures are allocated in the malloc arena. + The linked list is kept in order of increasing '.data' members. + The data blocks abut each other; if b->next is non-nil, then + b->data + b->size == b->next->data. */ +typedef struct bp +{ + struct bp *next; + struct bp *prev; + POINTER *variable; + POINTER data; + SIZE size; + POINTER new_data; /* tmporarily used for relocation */ + /* Heap this bloc is in. */ + struct heap *heap; +} *bloc_ptr; + +#define NIL_BLOC ((bloc_ptr) 0) +#define BLOC_PTR_SIZE (sizeof (struct bp)) + +/* Head and tail of the list of relocatable blocs. */ +static bloc_ptr first_bloc, last_bloc; + + +/* Functions to get and return memory from the system. */ + +/* Find the heap that ADDRESS falls within. */ + +static heap_ptr +find_heap (address) + POINTER address; +{ + heap_ptr heap; + + for (heap = last_heap; heap; heap = heap->prev) + { + if (heap->start <= address && address <= heap->end) + return heap; + } + + return NIL_HEAP; +} + +/* Find SIZE bytes of space in a heap. + Try to get them at ADDRESS (which must fall within some heap's range) + if we can get that many within one heap. + + If enough space is not presently available in our reserve, this means + getting more page-aligned space from the system. If the retuned space + is not contiguos to the last heap, allocate a new heap, and append it + + obtain does not try to keep track of whether space is in use + or not in use. It just returns the address of SIZE bytes that + fall within a single heap. If you call obtain twice in a row + with the same arguments, you typically get the same value. + to the heap list. It's the caller's responsibility to keep + track of what space is in use. + + Return the address of the space if all went well, or zero if we couldn't + allocate the memory. */ + +static POINTER +obtain (address, size) + POINTER address; + SIZE size; +{ + heap_ptr heap; + SIZE already_available; + + /* Find the heap that ADDRESS falls within. */ + for (heap = last_heap; heap; heap = heap->prev) + { + if (heap->start <= address && address <= heap->end) + break; + } + + if (! heap) + abort (); + + /* If we can't fit SIZE bytes in that heap, + try successive later heaps. */ + while (heap && address + size > heap->end) + { + heap = heap->next; + if (heap == NIL_HEAP) + break; + address = heap->bloc_start; + } + + /* If we can't fit them within any existing heap, + get more space. */ + if (heap == NIL_HEAP) + { + POINTER new = (*real_morecore)(0); + SIZE get; + + already_available = (char *)last_heap->end - (char *)address; + + if (new != last_heap->end) + { + /* Someone else called sbrk. Make a new heap. */ + + heap_ptr new_heap = (heap_ptr) MEM_ROUNDUP (new); + POINTER bloc_start = (POINTER) MEM_ROUNDUP ((POINTER)(new_heap + 1)); + + if ((*real_morecore) (bloc_start - new) != new) + return 0; + + new_heap->start = new; + new_heap->end = bloc_start; + new_heap->bloc_start = bloc_start; + new_heap->free = bloc_start; + new_heap->next = NIL_HEAP; + new_heap->prev = last_heap; + new_heap->first_bloc = NIL_BLOC; + new_heap->last_bloc = NIL_BLOC; + last_heap->next = new_heap; + last_heap = new_heap; + + address = bloc_start; + already_available = 0; + } + + /* Add space to the last heap (which we may have just created). + Get some extra, so we can come here less often. */ + + get = size + extra_bytes - already_available; + get = (char *) ROUNDUP ((char *)last_heap->end + get) + - (char *) last_heap->end; + + if ((*real_morecore) (get) != last_heap->end) + return 0; + + last_heap->end += get; + } + + return address; +} + +/* Return unused heap space to the system + if there is a lot of unused space now. + This can make the last heap smaller; + it can also eliminate the last heap entirely. */ + +static void +relinquish () +{ + register heap_ptr h; + int excess = 0; + + /* Add the amount of space beyond break_value + in all heaps which have extend beyond break_value at all. */ + + for (h = last_heap; h && break_value < h->end; h = h->prev) + { + excess += (char *) h->end - (char *) ((break_value < h->bloc_start) + ? h->bloc_start : break_value); + } + + if (excess > extra_bytes * 2 && (*real_morecore) (0) == last_heap->end) + { + /* Keep extra_bytes worth of empty space. + And don't free anything unless we can free at least extra_bytes. */ + excess -= extra_bytes; + + if ((char *)last_heap->end - (char *)last_heap->bloc_start <= excess) + { + /* This heap should have no blocs in it. */ + if (last_heap->first_bloc != NIL_BLOC + || last_heap->last_bloc != NIL_BLOC) + abort (); + + /* Return the last heap, with its header, to the system. */ + excess = (char *)last_heap->end - (char *)last_heap->start; + last_heap = last_heap->prev; + last_heap->next = NIL_HEAP; + } + else + { + excess = (char *) last_heap->end + - (char *) ROUNDUP ((char *)last_heap->end - excess); + last_heap->end -= excess; + } + + if ((*real_morecore) (- excess) == 0) + abort (); + } +} + +/* The meat - allocating, freeing, and relocating blocs. */ + +/* Find the bloc referenced by the address in PTR. Returns a pointer + to that block. */ + +static bloc_ptr +find_bloc (ptr) + POINTER *ptr; +{ + register bloc_ptr p = first_bloc; + + while (p != NIL_BLOC) + { + if (p->variable == ptr && p->data == *ptr) + return p; + + p = p->next; + } + + return p; +} + +/* Allocate a bloc of SIZE bytes and append it to the chain of blocs. + Returns a pointer to the new bloc, or zero if we couldn't allocate + memory for the new block. */ + +static bloc_ptr +get_bloc (size) + SIZE size; +{ + register bloc_ptr new_bloc; + register heap_ptr heap; + + if (! (new_bloc = (bloc_ptr) malloc (BLOC_PTR_SIZE)) + || ! (new_bloc->data = obtain (break_value, size))) + { + if (new_bloc) + free (new_bloc); + + return 0; + } + + break_value = new_bloc->data + size; + + new_bloc->size = size; + new_bloc->next = NIL_BLOC; + new_bloc->variable = (POINTER *) NIL; + new_bloc->new_data = 0; + + /* Record in the heap that this space is in use. */ + heap = find_heap (new_bloc->data); + heap->free = break_value; + + /* Maintain the correspondence between heaps and blocs. */ + new_bloc->heap = heap; + heap->last_bloc = new_bloc; + if (heap->first_bloc == NIL_BLOC) + heap->first_bloc = new_bloc; + + /* Put this bloc on the doubly-linked list of blocs. */ + if (first_bloc) + { + new_bloc->prev = last_bloc; + last_bloc->next = new_bloc; + last_bloc = new_bloc; + } + else + { + first_bloc = last_bloc = new_bloc; + new_bloc->prev = NIL_BLOC; + } + + return new_bloc; +} + +/* Calculate new locations of blocs in the list beginning with BLOC, + relocating it to start at ADDRESS, in heap HEAP. If enough space is + not presently available in our reserve, call obtain for + more space. + + Store the new location of each bloc in its new_data field. + Do not touch the contents of blocs or break_value. */ + +static int +relocate_blocs (bloc, heap, address) + bloc_ptr bloc; + heap_ptr heap; + POINTER address; +{ + register bloc_ptr b = bloc; + + while (b) + { + /* If bloc B won't fit within HEAP, + move to the next heap and try again. */ + while (heap && address + b->size > heap->end) + { + heap = heap->next; + if (heap == NIL_HEAP) + break; + address = heap->bloc_start; + } + + /* If BLOC won't fit in any heap, + get enough new space to hold BLOC and all following blocs. */ + if (heap == NIL_HEAP) + { + register bloc_ptr tb = b; + register SIZE s = 0; + + /* Add up the size of all the following blocs. */ + while (tb != NIL_BLOC) + { + s += tb->size; + tb = tb->next; + } + + /* Get that space. */ + address = obtain (address, s); + if (address == 0) + return 0; + + heap = last_heap; + } + + /* Record the new address of this bloc + and update where the next bloc can start. */ + b->new_data = address; + address += b->size; + b = b->next; + } + + return 1; +} + +/* Reorder the bloc BLOC to go before bloc BEFORE in the doubly linked list. + This is necessary if we put the memory of space of BLOC + before that of BEFORE. */ + +static void +reorder_bloc (bloc, before) + bloc_ptr bloc, before; +{ + bloc_ptr prev, next; + + /* Splice BLOC out from where it is. */ + prev = bloc->prev; + next = bloc->next; + + if (prev) + prev->next = next; + if (next) + next->prev = prev; + + /* Splice it in before BEFORE. */ + prev = before->prev; + + if (prev) + prev->next = bloc; + bloc->prev = prev; + + before->prev = bloc; + bloc->next = before; +} + +/* Update the records of which heaps contain which blocs, starting + with heap HEAP and bloc BLOC. */ + +static void +update_heap_bloc_correspondence (bloc, heap) + bloc_ptr bloc; + heap_ptr heap; +{ + register bloc_ptr b; + + /* Initialize HEAP's status to reflect blocs before BLOC. */ + if (bloc != NIL_BLOC && bloc->prev != NIL_BLOC && bloc->prev->heap == heap) + { + /* The previous bloc is in HEAP. */ + heap->last_bloc = bloc->prev; + heap->free = bloc->prev->data + bloc->prev->size; + } + else + { + /* HEAP contains no blocs before BLOC. */ + heap->first_bloc = NIL_BLOC; + heap->last_bloc = NIL_BLOC; + heap->free = heap->bloc_start; + } + + /* Advance through blocs one by one. */ + for (b = bloc; b != NIL_BLOC; b = b->next) + { + /* Advance through heaps, marking them empty, + till we get to the one that B is in. */ + while (heap) + { + if (heap->bloc_start <= b->data && b->data <= heap->end) + break; + heap = heap->next; + /* We know HEAP is not null now, + because there has to be space for bloc B. */ + heap->first_bloc = NIL_BLOC; + heap->last_bloc = NIL_BLOC; + heap->free = heap->bloc_start; + } + + /* Update HEAP's status for bloc B. */ + heap->free = b->data + b->size; + heap->last_bloc = b; + if (heap->first_bloc == NIL_BLOC) + heap->first_bloc = b; + + /* Record that B is in HEAP. */ + b->heap = heap; + } + + /* If there are any remaining heaps and no blocs left, + mark those heaps as empty. */ + heap = heap->next; + while (heap) + { + heap->first_bloc = NIL_BLOC; + heap->last_bloc = NIL_BLOC; + heap->free = heap->bloc_start; + heap = heap->next; + } +} + +/* Resize BLOC to SIZE bytes. This relocates the blocs + that come after BLOC in memory. */ + +static int +resize_bloc (bloc, size) + bloc_ptr bloc; + SIZE size; +{ + register bloc_ptr b; + heap_ptr heap; + POINTER address; + SIZE old_size; + + if (bloc == NIL_BLOC || size == bloc->size) + return 1; + + for (heap = first_heap; heap != NIL_HEAP; heap = heap->next) + { + if (heap->bloc_start <= bloc->data && bloc->data <= heap->end) + break; + } + + if (heap == NIL_HEAP) + abort (); + + old_size = bloc->size; + bloc->size = size; + + /* Note that bloc could be moved into the previous heap. */ + address = (bloc->prev ? bloc->prev->data + bloc->prev->size + : first_heap->bloc_start); + while (heap) + { + if (heap->bloc_start <= address && address <= heap->end) + break; + heap = heap->prev; + } + + if (! relocate_blocs (bloc, heap, address)) + { + bloc->size = old_size; + return 0; + } + + if (size > old_size) + { + for (b = last_bloc; b != bloc; b = b->prev) + { + safe_bcopy (b->data, b->new_data, b->size); + *b->variable = b->data = b->new_data; + } + safe_bcopy (bloc->data, bloc->new_data, old_size); + bzero (bloc->new_data + old_size, size - old_size); + *bloc->variable = bloc->data = bloc->new_data; + } + else + { + for (b = bloc; b != NIL_BLOC; b = b->next) + { + safe_bcopy (b->data, b->new_data, b->size); + *b->variable = b->data = b->new_data; + } + } + + update_heap_bloc_correspondence (bloc, heap); + + break_value = (last_bloc ? last_bloc->data + last_bloc->size + : first_heap->bloc_start); + return 1; +} + +/* Free BLOC from the chain of blocs, relocating any blocs above it. + This may return space to the system. */ + +static void +free_bloc (bloc) + bloc_ptr bloc; +{ + heap_ptr heap = bloc->heap; + + resize_bloc (bloc, 0); + + if (bloc == first_bloc && bloc == last_bloc) + { + first_bloc = last_bloc = NIL_BLOC; + } + else if (bloc == last_bloc) + { + last_bloc = bloc->prev; + last_bloc->next = NIL_BLOC; + } + else if (bloc == first_bloc) + { + first_bloc = bloc->next; + first_bloc->prev = NIL_BLOC; + } + else + { + bloc->next->prev = bloc->prev; + bloc->prev->next = bloc->next; + } + + /* Update the records of which blocs are in HEAP. */ + if (heap->first_bloc == bloc) + { + if (bloc->next->heap == heap) + heap->first_bloc = bloc->next; + else + heap->first_bloc = heap->last_bloc = NIL_BLOC; + } + if (heap->last_bloc == bloc) + { + if (bloc->prev->heap == heap) + heap->last_bloc = bloc->prev; + else + heap->first_bloc = heap->last_bloc = NIL_BLOC; + } + + relinquish (); + free (bloc); +} + +/* Interface routines. */ + +static int use_relocatable_buffers; +static int r_alloc_freeze_level; + +/* Obtain SIZE bytes of storage from the free pool, or the system, as + necessary. If relocatable blocs are in use, this means relocating + them. This function gets plugged into the GNU malloc's __morecore + hook. + + We provide hysteresis, never relocating by less than extra_bytes. + + If we're out of memory, we should return zero, to imitate the other + __morecore hook values - in particular, __default_morecore in the + GNU malloc package. */ + +POINTER +r_alloc_sbrk (size) + long size; +{ + register bloc_ptr b; + POINTER address; + + if (! use_relocatable_buffers) + return (*real_morecore) (size); + + if (size == 0) + return virtual_break_value; + + if (size > 0) + { + /* Allocate a page-aligned space. GNU malloc would reclaim an + extra space if we passed an unaligned one. But we could + not always find a space which is contiguos to the previous. */ + POINTER new_bloc_start; + heap_ptr h = first_heap; + SIZE get = ROUNDUP (size); + + address = (POINTER) ROUNDUP (virtual_break_value); + + /* Search the list upward for a heap which is large enough. */ + while ((char *) h->end < (char *) MEM_ROUNDUP ((char *)address + get)) + { + h = h->next; + if (h == NIL_HEAP) + break; + address = (POINTER) ROUNDUP (h->start); + } + + /* If not found, obtain more space. */ + if (h == NIL_HEAP) + { + get += extra_bytes + page_size; + + if (r_alloc_freeze_level > 0 || ! obtain (address, get)) + return 0; + + if (first_heap == last_heap) + address = (POINTER) ROUNDUP (virtual_break_value); + else + address = (POINTER) ROUNDUP (last_heap->start); + h = last_heap; + } + + new_bloc_start = (POINTER) MEM_ROUNDUP ((char *)address + get); + + if (first_heap->bloc_start < new_bloc_start) + { + /* Move all blocs upward. */ + if (r_alloc_freeze_level > 0 + || ! relocate_blocs (first_bloc, h, new_bloc_start)) + return 0; + + /* Note that (POINTER)(h+1) <= new_bloc_start since + get >= page_size, so the following does not destroy the heap + header. */ + for (b = last_bloc; b != NIL_BLOC; b = b->prev) + { + safe_bcopy (b->data, b->new_data, b->size); + *b->variable = b->data = b->new_data; + } + + h->bloc_start = new_bloc_start; + + update_heap_bloc_correspondence (first_bloc, h); + } + + if (h != first_heap) + { + /* Give up managing heaps below the one the new + virtual_break_value points to. */ + first_heap->prev = NIL_HEAP; + first_heap->next = h->next; + first_heap->start = h->start; + first_heap->end = h->end; + first_heap->free = h->free; + first_heap->first_bloc = h->first_bloc; + first_heap->last_bloc = h->last_bloc; + first_heap->bloc_start = h->bloc_start; + + if (first_heap->next) + first_heap->next->prev = first_heap; + else + last_heap = first_heap; + } + + bzero (address, size); + } + else /* size < 0 */ + { + SIZE excess = (char *)first_heap->bloc_start + - ((char *)virtual_break_value + size); + + address = virtual_break_value; + + if (r_alloc_freeze_level == 0 && excess > 2 * extra_bytes) + { + excess -= extra_bytes; + first_heap->bloc_start + = (POINTER) MEM_ROUNDUP ((char *)first_heap->bloc_start - excess); + + relocate_blocs (first_bloc, first_heap, first_heap->bloc_start); + + for (b = first_bloc; b != NIL_BLOC; b = b->next) + { + safe_bcopy (b->data, b->new_data, b->size); + *b->variable = b->data = b->new_data; + } + } + + if ((char *)virtual_break_value + size < (char *)first_heap->start) + { + /* We found an additional space below the first heap */ + first_heap->start = (POINTER) ((char *)virtual_break_value + size); + } + } + + virtual_break_value = (POINTER) ((char *)address + size); + break_value = (last_bloc + ? last_bloc->data + last_bloc->size + : first_heap->bloc_start); + if (size < 0) + relinquish (); + + return address; +} + +/* Allocate a relocatable bloc of storage of size SIZE. A pointer to + the data is returned in *PTR. PTR is thus the address of some variable + which will use the data area. + + If we can't allocate the necessary memory, set *PTR to zero, and + return zero. */ + +POINTER +r_alloc (ptr, size) + POINTER *ptr; + SIZE size; +{ + register bloc_ptr new_bloc; + + if (! r_alloc_initialized) + r_alloc_init (); + + new_bloc = get_bloc (MEM_ROUNDUP (size)); + if (new_bloc) + { + new_bloc->variable = ptr; + *ptr = new_bloc->data; + } + else + *ptr = 0; + + return *ptr; +} + +/* Free a bloc of relocatable storage whose data is pointed to by PTR. + Store 0 in *PTR to show there's no block allocated. */ + +void +r_alloc_free (ptr) + register POINTER *ptr; +{ + register bloc_ptr dead_bloc; + + dead_bloc = find_bloc (ptr); + if (dead_bloc == NIL_BLOC) + abort (); + + free_bloc (dead_bloc); + *ptr = 0; +} + +/* Given a pointer at address PTR to relocatable data, resize it to SIZE. + Do this by shifting all blocks above this one up in memory, unless + SIZE is less than or equal to the current bloc size, in which case + do nothing. + + Change *PTR to reflect the new bloc, and return this value. + + If more memory cannot be allocated, then leave *PTR unchanged, and + return zero. */ + +POINTER +r_re_alloc (ptr, size) + POINTER *ptr; + SIZE size; +{ + register bloc_ptr bloc; + + bloc = find_bloc (ptr); + if (bloc == NIL_BLOC) + abort (); + + if (size <= bloc->size) + /* Wouldn't it be useful to actually resize the bloc here? */ + return *ptr; + + if (! resize_bloc (bloc, MEM_ROUNDUP (size))) + return 0; + + return *ptr; +} + +/* Disable relocations, after making room for at least SIZE bytes + of non-relocatable heap if possible. The relocatable blocs are + guaranteed to hold still until thawed, even if this means that + malloc must return a null pointer. */ + +void +r_alloc_freeze (size) + long size; +{ + /* If already frozen, we can't make any more room, so don't try. */ + if (r_alloc_freeze_level > 0) + size = 0; + /* If we can't get the amount requested, half is better than nothing. */ + while (size > 0 && r_alloc_sbrk (size) == 0) + size /= 2; + ++r_alloc_freeze_level; + if (size > 0) + r_alloc_sbrk (-size); +} + +void +r_alloc_thaw () +{ + if (--r_alloc_freeze_level < 0) + abort (); +} + +/* The hook `malloc' uses for the function which gets more space + from the system. */ +extern POINTER (*__morecore) (); + +/* Initialize various things for memory allocation. */ + +static void +r_alloc_init () +{ + if (r_alloc_initialized) + return; + + r_alloc_initialized = 1; + real_morecore = __morecore; + __morecore = r_alloc_sbrk; + + first_heap = last_heap = &heap_base; + first_heap->next = first_heap->prev = NIL_HEAP; + first_heap->start = first_heap->bloc_start + = virtual_break_value = break_value = (*real_morecore) (0); + if (break_value == NIL) + abort (); + + page_size = PAGE; + extra_bytes = ROUNDUP (50000); + + first_heap->end = (POINTER) ROUNDUP (first_heap->start); + + /* The extra call to real_morecore guarantees that the end of the + address space is a multiple of page_size, even if page_size is + not really the page size of the system running the binary in + which page_size is stored. This allows a binary to be built on a + system with one page size and run on a system with a smaller page + size. */ + (*real_morecore) (first_heap->end - first_heap->start); + + /* Clear the rest of the last page; this memory is in our address space + even though it is after the sbrk value. */ + /* Doubly true, with the additional call that explicitly adds the + rest of that page to the address space. */ + bzero (first_heap->start, first_heap->end - first_heap->start); + virtual_break_value = break_value = first_heap->bloc_start = first_heap->end; + use_relocatable_buffers = 1; +} +#ifdef DEBUG +#include + +int +r_alloc_check () +{ + int found = 0; + heap_ptr h, ph = 0; + bloc_ptr b, pb = 0; + + if (!r_alloc_initialized) + return; + + assert (first_heap); + assert (last_heap->end <= (POINTER) sbrk (0)); + assert ((POINTER) first_heap < first_heap->start); + assert (first_heap->start <= virtual_break_value); + assert (virtual_break_value <= first_heap->end); + + for (h = first_heap; h; h = h->next) + { + assert (h->prev == ph); + assert ((POINTER) ROUNDUP (h->end) == h->end); + assert ((POINTER) MEM_ROUNDUP (h->start) == h->start); + assert ((POINTER) MEM_ROUNDUP (h->bloc_start) == h->bloc_start); + assert (h->start <= h->bloc_start && h->bloc_start <= h->end); + + if (ph) + { + assert (ph->end < h->start); + assert (h->start <= (POINTER)h && (POINTER)(h+1) <= h->bloc_start); + } + + if (h->bloc_start <= break_value && break_value <= h->end) + found = 1; + + ph = h; + } + + assert (found); + assert (last_heap == ph); + + for (b = first_bloc; b; b = b->next) + { + assert (b->prev == pb); + assert ((POINTER) MEM_ROUNDUP (b->data) == b->data); + assert ((SIZE) MEM_ROUNDUP (b->size) == b->size); + + ph = 0; + for (h = first_heap; h; h = h->next) + { + if (h->bloc_start <= b->data && b->data + b->size <= h->end) + break; + ph = h; + } + + assert (h); + + if (pb && pb->data + pb->size != b->data) + { + assert (ph && b->data == h->bloc_start); + while (ph) + { + if (ph->bloc_start <= pb->data + && pb->data + pb->size <= ph->end) + { + assert (pb->data + pb->size + b->size > ph->end); + break; + } + else + { + assert (ph->bloc_start + b->size > ph->end); + } + ph = ph->prev; + } + } + pb = b; + } + + assert (last_bloc == pb); + + if (last_bloc) + assert (last_bloc->data + last_bloc->size == break_value); + else + assert (first_heap->bloc_start == break_value); +} +#endif /* DEBUG */ diff --git a/malloc/realloc.c b/malloc/realloc.c new file mode 100644 index 0000000..4521a61 --- /dev/null +++ b/malloc/realloc.c @@ -0,0 +1,219 @@ +/* Change the size of a block allocated by `malloc'. + Copyright 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +#if (defined (MEMMOVE_MISSING) || \ + !defined(_LIBC) && !defined(STDC_HEADERS) && !defined(USG)) + +/* Snarfed directly from Emacs src/dispnew.c: + XXX Should use system bcopy if it handles overlap. */ +#ifndef emacs + +/* Like bcopy except never gets confused by overlap. */ + +static void +safe_bcopy (from, to, size) + char *from, *to; + int size; +{ + if (size <= 0 || from == to) + return; + + /* If the source and destination don't overlap, then bcopy can + handle it. If they do overlap, but the destination is lower in + memory than the source, we'll assume bcopy can handle that. */ + if (to < from || from + size <= to) + bcopy (from, to, size); + + /* Otherwise, we'll copy from the end. */ + else + { + register char *endf = from + size; + register char *endt = to + size; + + /* If TO - FROM is large, then we should break the copy into + nonoverlapping chunks of TO - FROM bytes each. However, if + TO - FROM is small, then the bcopy function call overhead + makes this not worth it. The crossover point could be about + anywhere. Since I don't think the obvious copy loop is too + bad, I'm trying to err in its favor. */ + if (to - from < 64) + { + do + *--endt = *--endf; + while (endf != from); + } + else + { + for (;;) + { + endt -= (to - from); + endf -= (to - from); + + if (endt < to) + break; + + bcopy (endf, endt, to - from); + } + + /* If SIZE wasn't a multiple of TO - FROM, there will be a + little left over. The amount left over is + (endt + (to - from)) - to, which is endt - from. */ + bcopy (from, to, endt - from); + } + } +} +#endif /* Not emacs. */ + +#define memmove(to, from, size) safe_bcopy ((from), (to), (size)) + +#endif + + +#define min(A, B) ((A) < (B) ? (A) : (B)) + +/* Debugging hook for realloc. */ +__ptr_t (*__realloc_hook) __P ((__ptr_t __ptr, __malloc_size_t __size)); + +/* Resize the given region to the new size, returning a pointer + to the (possibly moved) region. This is optimized for speed; + some benchmarks seem to indicate that greater compactness is + achieved by unconditionally allocating and copying to a + new region. This module has incestuous knowledge of the + internals of both free and malloc. */ +__ptr_t +realloc (ptr, size) + __ptr_t ptr; + __malloc_size_t size; +{ + __ptr_t result; + int type; + __malloc_size_t block, blocks, oldlimit; + + if (size == 0) + { + free (ptr); + return malloc (0); + } + else if (ptr == NULL) + return malloc (size); + + if (__realloc_hook != NULL) + return (*__realloc_hook) (ptr, size); + + block = BLOCK (ptr); + + type = _heapinfo[block].busy.type; + switch (type) + { + case 0: + /* Maybe reallocate a large block to a small fragment. */ + if (size <= BLOCKSIZE / 2) + { + result = malloc (size); + if (result != NULL) + { + memcpy (result, ptr, size); + _free_internal (ptr); + return result; + } + } + + /* The new size is a large allocation as well; + see if we can hold it in place. */ + blocks = BLOCKIFY (size); + if (blocks < _heapinfo[block].busy.info.size) + { + /* The new size is smaller; return + excess memory to the free list. */ + _heapinfo[block + blocks].busy.type = 0; + _heapinfo[block + blocks].busy.info.size + = _heapinfo[block].busy.info.size - blocks; + _heapinfo[block].busy.info.size = blocks; + /* We have just created a new chunk by splitting a chunk in two. + Now we will free this chunk; increment the statistics counter + so it doesn't become wrong when _free_internal decrements it. */ + ++_chunks_used; + _free_internal (ADDRESS (block + blocks)); + result = ptr; + } + else if (blocks == _heapinfo[block].busy.info.size) + /* No size change necessary. */ + result = ptr; + else + { + /* Won't fit, so allocate a new region that will. + Free the old region first in case there is sufficient + adjacent free space to grow without moving. */ + blocks = _heapinfo[block].busy.info.size; + /* Prevent free from actually returning memory to the system. */ + oldlimit = _heaplimit; + _heaplimit = 0; + _free_internal (ptr); + _heaplimit = oldlimit; + result = malloc (size); + if (result == NULL) + { + /* Now we're really in trouble. We have to unfree + the thing we just freed. Unfortunately it might + have been coalesced with its neighbors. */ + if (_heapindex == block) + (void) malloc (blocks * BLOCKSIZE); + else + { + __ptr_t previous = malloc ((block - _heapindex) * BLOCKSIZE); + (void) malloc (blocks * BLOCKSIZE); + _free_internal (previous); + } + return NULL; + } + if (ptr != result) + memmove (result, ptr, blocks * BLOCKSIZE); + } + break; + + default: + /* Old size is a fragment; type is logarithm + to base two of the fragment size. */ + if (size > (__malloc_size_t) (1 << (type - 1)) && + size <= (__malloc_size_t) (1 << type)) + /* The new size is the same kind of fragment. */ + result = ptr; + else + { + /* The new size is different; allocate a new space, + and copy the lesser of the new size and the old. */ + result = malloc (size); + if (result == NULL) + return NULL; + memcpy (result, ptr, min (size, (__malloc_size_t) 1 << type)); + free (ptr); + } + break; + } + + return result; +} diff --git a/malloc/valloc.c b/malloc/valloc.c new file mode 100644 index 0000000..58c13b3 --- /dev/null +++ b/malloc/valloc.c @@ -0,0 +1,46 @@ +/* Allocate memory on a page boundary. + Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#if defined (__GNU_LIBRARY__) || defined (_LIBC) +#include +#include +extern size_t __getpagesize __P ((void)); +#else +#include "getpagesize.h" +#define __getpagesize() getpagesize() +#endif + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#endif + +static __malloc_size_t pagesize; + +__ptr_t +valloc (size) + __malloc_size_t size; +{ + if (pagesize == 0) + pagesize = __getpagesize (); + + return memalign (pagesize, size); +} diff --git a/malloc/vm-limit.c b/malloc/vm-limit.c new file mode 100644 index 0000000..d5215d3 --- /dev/null +++ b/malloc/vm-limit.c @@ -0,0 +1,135 @@ +/* Functions for memory limit warnings. + Copyright (C) 1990, 1992 Free Software Foundation, Inc. + + +This file is part of the GNU C Library. Its master source is NOT part of +the C library, however. The master source lives in /gd/gnu/lib. + +The GNU C Library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +The GNU C Library 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 +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with the GNU C Library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. */ + +#ifdef emacs +#include +#include "lisp.h" +#endif + +#ifndef emacs +#include +typedef size_t SIZE; +typedef void *POINTER; +#define EXCEEDS_LISP_PTR(x) 0 +#endif + +#include "mem-limits.h" + +/* + Level number of warnings already issued. + 0 -- no warnings issued. + 1 -- 75% warning already issued. + 2 -- 85% warning already issued. + 3 -- 95% warning issued; keep warning frequently. +*/ +static int warnlevel; + +/* Function to call to issue a warning; + 0 means don't issue them. */ +static void (*warn_function) (); + +/* Get more memory space, complaining if we're near the end. */ + +static void +check_memory_limits () +{ + extern POINTER (*__morecore) (); + + register POINTER cp; + unsigned long five_percent; + unsigned long data_size; + + if (lim_data == 0) + get_lim_data (); + five_percent = lim_data / 20; + + /* Find current end of memory and issue warning if getting near max */ + cp = (char *) (*__morecore) (0); + data_size = (char *) cp - (char *) data_space_start; + + if (warn_function) + switch (warnlevel) + { + case 0: + if (data_size > five_percent * 15) + { + warnlevel++; + (*warn_function) ("Warning: past 75% of memory limit"); + } + break; + + case 1: + if (data_size > five_percent * 17) + { + warnlevel++; + (*warn_function) ("Warning: past 85% of memory limit"); + } + break; + + case 2: + if (data_size > five_percent * 19) + { + warnlevel++; + (*warn_function) ("Warning: past 95% of memory limit"); + } + break; + + default: + (*warn_function) ("Warning: past acceptable memory limits"); + break; + } + + /* If we go down below 70% full, issue another 75% warning + when we go up again. */ + if (data_size < five_percent * 14) + warnlevel = 0; + /* If we go down below 80% full, issue another 85% warning + when we go up again. */ + else if (warnlevel > 1 && data_size < five_percent * 16) + warnlevel = 1; + /* If we go down below 90% full, issue another 95% warning + when we go up again. */ + else if (warnlevel > 2 && data_size < five_percent * 18) + warnlevel = 2; + + if (EXCEEDS_LISP_PTR (cp)) + (*warn_function) ("Warning: memory in use exceeds lisp pointer size"); +} + +/* Cause reinitialization based on job parameters; + also declare where the end of pure storage is. */ + +void +memory_warnings (start, warnfun) + POINTER start; + void (*warnfun) (); +{ + extern void (* __after_morecore_hook) (); /* From gmalloc.c */ + + if (start) + data_space_start = start; + else + data_space_start = start_of_data (); + + warn_function = warnfun; + __after_morecore_hook = check_memory_limits; +} diff --git a/meschach/arnoldi.c b/meschach/arnoldi.c new file mode 100644 index 0000000..ca8cb12 --- /dev/null +++ b/meschach/arnoldi.c @@ -0,0 +1,187 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + +/* + Arnoldi method for finding eigenvalues of large non-symmetric + matrices +*/ +#include +#include +#include "matrix.h" +#include "matrix2.h" +#include "sparse.h" + +static char rcsid[] = "$Id: arnoldi.c,v 1.1 2001/03/01 17:18:30 rfranke Exp $"; + +/* arnoldi -- an implementation of the Arnoldi method */ +MAT *arnoldi(A,A_param,x0,m,h_rem,Q,H) +VEC *(*A)(); +void *A_param; +VEC *x0; +int m; +Real *h_rem; +MAT *Q, *H; +{ + static VEC *v=VNULL, *u=VNULL, *r=VNULL, *s=VNULL, *tmp=VNULL; + int i; + Real h_val; + + if ( ! A || ! Q || ! x0 ) + error(E_NULL,"arnoldi"); + if ( m <= 0 ) + error(E_BOUNDS,"arnoldi"); + if ( Q->n != x0->dim || Q->m != m ) + error(E_SIZES,"arnoldi"); + + m_zero(Q); + H = m_resize(H,m,m); + m_zero(H); + u = v_resize(u,x0->dim); + v = v_resize(v,x0->dim); + r = v_resize(r,m); + s = v_resize(s,m); + tmp = v_resize(tmp,x0->dim); + MEM_STAT_REG(u,TYPE_VEC); + MEM_STAT_REG(v,TYPE_VEC); + MEM_STAT_REG(r,TYPE_VEC); + MEM_STAT_REG(s,TYPE_VEC); + MEM_STAT_REG(tmp,TYPE_VEC); + sv_mlt(1.0/v_norm2(x0),x0,v); + for ( i = 0; i < m; i++ ) + { + set_row(Q,i,v); + u = (*A)(A_param,v,u); + r = mv_mlt(Q,u,r); + tmp = vm_mlt(Q,r,tmp); + v_sub(u,tmp,u); + h_val = v_norm2(u); + /* if u == 0 then we have an exact subspace */ + if ( h_val == 0.0 ) + { + *h_rem = h_val; + return H; + } + /* iterative refinement -- ensures near orthogonality */ + do { + s = mv_mlt(Q,u,s); + tmp = vm_mlt(Q,s,tmp); + v_sub(u,tmp,u); + v_add(r,s,r); + } while ( v_norm2(s) > 0.1*(h_val = v_norm2(u)) ); + /* now that u is nearly orthogonal to Q, update H */ + set_col(H,i,r); + if ( i == m-1 ) + { + *h_rem = h_val; + continue; + } + /* H->me[i+1][i] = h_val; */ + m_set_val(H,i+1,i,h_val); + sv_mlt(1.0/h_val,u,v); + } + + return H; +} + +/* sp_arnoldi -- uses arnoldi() with an explicit representation of A */ +MAT *sp_arnoldi(A,x0,m,h_rem,Q,H) +SPMAT *A; +VEC *x0; +int m; +Real *h_rem; +MAT *Q, *H; +{ return arnoldi(sp_mv_mlt,A,x0,m,h_rem,Q,H); } + +/* gmres -- generalised minimum residual algorithm of Saad & Schultz + SIAM J. Sci. Stat. Comp. v.7, pp.856--869 (1986) + -- y is overwritten with the solution */ +VEC *gmres(A,A_param,m,Q,R,b,tol,x) +VEC *(*A)(); +void *A_param; +VEC *b, *x; +int m; +MAT *Q, *R; +double tol; +{ + static VEC *v=VNULL, *u=VNULL, *r=VNULL, *tmp=VNULL, *rhs=VNULL; + static VEC *diag=VNULL, *beta=VNULL; + int i; + Real h_val, norm_b; + + if ( ! A || ! Q || ! b || ! R ) + error(E_NULL,"gmres"); + if ( m <= 0 ) + error(E_BOUNDS,"gmres"); + if ( Q->n != b->dim || Q->m != m ) + error(E_SIZES,"gmres"); + + x = v_copy(b,x); + m_zero(Q); + R = m_resize(R,m+1,m); + m_zero(R); + u = v_resize(u,x->dim); + v = v_resize(v,x->dim); + tmp = v_resize(tmp,x->dim); + rhs = v_resize(rhs,m+1); + MEM_STAT_REG(u,TYPE_VEC); + MEM_STAT_REG(v,TYPE_VEC); + MEM_STAT_REG(r,TYPE_VEC); + MEM_STAT_REG(tmp,TYPE_VEC); + MEM_STAT_REG(rhs,TYPE_VEC); + norm_b = v_norm2(x); + if ( norm_b == 0.0 ) + error(E_RANGE,"gmres"); + sv_mlt(1.0/norm_b,x,v); + + for ( i = 0; i < m; i++ ) + { + set_row(Q,i,v); + tracecatch(u = (*A)(A_param,v,u),"gmres"); + r = mv_mlt(Q,u,r); + tmp = vm_mlt(Q,r,tmp); + v_sub(u,tmp,u); + h_val = v_norm2(u); + set_col(R,i,r); + R->me[i+1][i] = h_val; + sv_mlt(1.0/h_val,u,v); + } + + /* use i x i submatrix of R */ + R = m_resize(R,i+1,i); + rhs = v_resize(rhs,i+1); + v_zero(rhs); + rhs->ve[0] = norm_b; + tmp = v_resize(tmp,i); + diag = v_resize(diag,i+1); + beta = v_resize(beta,i+1); + MEM_STAT_REG(beta,TYPE_VEC); + MEM_STAT_REG(diag,TYPE_VEC); + QRfactor(R,diag /* ,beta */); + tmp = QRsolve(R,diag, /* beta, */ rhs,tmp); + v_resize(tmp,m); + vm_mlt(Q,tmp,x); + + return x; +} diff --git a/meschach/bdfactor.c b/meschach/bdfactor.c new file mode 100644 index 0000000..1216106 --- /dev/null +++ b/meschach/bdfactor.c @@ -0,0 +1,598 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Band matrix factorisation routines + */ + +/* bdfactor.c 18/11/93 */ +static char rcsid[] = "$Id: bdfactor.c,v 1.1 2001/03/01 17:18:31 rfranke Exp $"; + +#include +#include +#include "matrix2.h" + + +/* generate band matrix + for a matrix with n columns, + lb subdiagonals and ub superdiagonals; + + Way of saving a band of a matrix: + first we save subdiagonals (from 0 to lb-1); + then main diagonal (in the lb row) + and then superdiagonals (from lb+1 to lb+ub) + in such a way that the elements which were previously + in one column are now also in one column +*/ + +BAND *bd_get(lb,ub,n) +int lb, ub, n; +{ + BAND *A; + + if (lb < 0 || ub < 0 || n <= 0) + error(E_NEG,"bd_get"); + + if ((A = NEW(BAND)) == (BAND *)NULL) + error(E_MEM,"bd_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_BAND,0,sizeof(BAND)); + mem_numvar(TYPE_BAND,1); + } + + lb = A->lb = min(n-1,lb); + ub = A->ub = min(n-1,ub); + A->mat = m_get(lb+ub+1,n); + return A; +} + +int bd_free(A) +BAND *A; +{ + if ( A == (BAND *)NULL || A->lb < 0 || A->ub < 0 ) + /* don't trust it */ + return (-1); + + if (A->mat) m_free(A->mat); + + if (mem_info_is_on()) { + mem_bytes(TYPE_BAND,sizeof(BAND),0); + mem_numvar(TYPE_BAND,-1); + } + + free((char *)A); + return 0; +} + + +/* resize band matrix */ + +BAND *bd_resize(A,new_lb,new_ub,new_n) +BAND *A; +int new_lb,new_ub,new_n; +{ + int lb,ub,i,j,l,shift,umin; + Real **Av; + + if (new_lb < 0 || new_ub < 0 || new_n <= 0) + error(E_NEG,"bd_resize"); + if ( ! A ) + return bd_get(new_lb,new_ub,new_n); + if ( A->lb+A->ub+1 > A->mat->m ) + error(E_INTERN,"bd_resize"); + + if ( A->lb == new_lb && A->ub == new_ub && A->mat->n == new_n ) + return A; + + lb = A->lb; + ub = A->ub; + Av = A->mat->me; + umin = min(ub,new_ub); + + /* ensure that unused triangles at edges are zero'd */ + + for ( i = 0; i < lb; i++ ) + for ( j = A->mat->n - lb + i; j < A->mat->n; j++ ) + Av[i][j] = 0.0; + for ( i = lb+1,l=1; l <= umin; i++,l++ ) + for ( j = 0; j < l; j++ ) + Av[i][j] = 0.0; + + new_lb = A->lb = min(new_lb,new_n-1); + new_ub = A->ub = min(new_ub,new_n-1); + A->mat = m_resize(A->mat,new_lb+new_ub+1,new_n); + Av = A->mat->me; + + /* if new_lb != lb then move the rows to get the main diag + in the new_lb row */ + + if (new_lb > lb) { + shift = new_lb-lb; + + for (i=lb+umin, l=i+shift; i >= 0; i--,l--) + MEM_COPY(Av[i],Av[l],new_n*sizeof(Real)); + for (l=shift-1; l >= 0; l--) + __zero__(Av[l],new_n); + } + else { /* new_lb < lb */ + shift = lb - new_lb; + + for (i=shift, l=0; i <= lb+umin; i++,l++) + MEM_COPY(Av[i],Av[l],new_n*sizeof(Real)); + for (i=lb+umin+1; i <= new_lb+new_ub; i++) + __zero__(Av[i],new_n); + } + + return A; +} + + + +BAND *bd_copy(A,B) +BAND *A,*B; +{ + int lb,ub,i,j,n; + + if ( !A ) + error(E_NULL,"bd_copy"); + + if (A == B) return B; + + n = A->mat->n; + if ( !B ) + B = bd_get(A->lb,A->ub,n); + else if (B->lb != A->lb || B->ub != A->ub || B->mat->n != n ) + B = bd_resize(B,A->lb,A->ub,n); + + if (A->mat == B->mat) return B; + ub = B->ub = A->ub; + lb = B->lb = A->lb; + + for ( i=0, j=n-lb; i <= lb; i++, j++ ) + MEM_COPY(A->mat->me[i],B->mat->me[i],j*sizeof(Real)); + + for ( i=lb+1, j=1; i <= lb+ub; i++, j++ ) + MEM_COPY(A->mat->me[i]+j,B->mat->me[i]+j,(n - j)*sizeof(Real)); + + return B; +} + + +/* copy band matrix to a square matrix */ +MAT *band2mat(bA,A) +BAND *bA; +MAT *A; +{ + int i,j,l,n,n1; + int lb, ub; + Real **bmat; + + if ( !bA || !A) + error(E_NULL,"band2mat"); + if ( bA->mat == A ) + error(E_INSITU,"band2mat"); + + ub = bA->ub; + lb = bA->lb; + n = bA->mat->n; + n1 = n-1; + bmat = bA->mat->me; + + A = m_resize(A,n,n); + m_zero(A); + + for (j=0; j < n; j++) + for (i=min(n1,j+lb),l=lb+j-i; i >= max(0,j-ub); i--,l++) + A->me[i][j] = bmat[l][j]; + + return A; +} + +/* copy a square matrix to a band matrix with + lb subdiagonals and ub superdiagonals */ +BAND *mat2band(A,lb,ub,bA) +BAND *bA; +MAT *A; +int lb, ub; +{ + int i, j, l, n1; + Real **bmat; + + if (! A || ! bA) + error(E_NULL,"mat2band"); + if (ub < 0 || lb < 0) + error(E_SIZES,"mat2band"); + if (bA->mat == A) + error(E_INSITU,"mat2band"); + + n1 = A->n-1; + lb = min(n1,lb); + ub = min(n1,ub); + bA = bd_resize(bA,lb,ub,n1+1); + bmat = bA->mat->me; + + for (j=0; j <= n1; j++) + for (i=min(n1,j+lb),l=lb+j-i; i >= max(0,j-ub); i--,l++) + bmat[l][j] = A->me[i][j]; + + return bA; +} + + + +/* transposition of matrix in; + out - matrix after transposition; + can be done in situ +*/ + +BAND *bd_transp(in,out) +BAND *in, *out; +{ + int i, j, jj, l, k, lb, ub, lub, n, n1; + int in_situ; + Real **in_v, **out_v; + + if ( in == (BAND *)NULL || in->mat == (MAT *)NULL ) + error(E_NULL,"bd_transp"); + + lb = in->lb; + ub = in->ub; + lub = lb+ub; + n = in->mat->n; + n1 = n-1; + + in_situ = ( in == out ); + if ( ! in_situ ) + out = bd_resize(out,ub,lb,n); + else + { /* only need to swap lb and ub fields */ + out->lb = ub; + out->ub = lb; + } + + in_v = in->mat->me; + + if (! in_situ) { + int sh_in,sh_out; + + out_v = out->mat->me; + for (i=0, l=lub, k=lb-i; i <= lub; i++,l--,k--) { + sh_in = max(-k,0); + sh_out = max(k,0); + MEM_COPY(&(in_v[i][sh_in]),&(out_v[l][sh_out]),n-sh_in-sh_out); + /********************************** + for (j=n1-sh_out, jj=n1-sh_in; j >= sh_in; j--,jj--) { + out_v[l][jj] = in_v[i][j]; + } + **********************************/ + } + } + else if (ub == lb) { + Real tmp; + + for (i=0, l=lub, k=lb-i; i < lb; i++,l--,k--) { + for (j=n1-k, jj=n1; j >= 0; j--,jj--) { + tmp = in_v[l][jj]; + in_v[l][jj] = in_v[i][j]; + in_v[i][j] = tmp; + } + } + } + else if (ub > lb) { /* hence i-ub <= 0 & l-lb >= 0 */ + int p,pp,lbi; + + for (i=0, l=lub; i < (lub+1)/2; i++,l--) { + lbi = lb-i; + for (j=l-lb, jj=0, p=max(-lbi,0), pp = max(l-ub,0); j <= n1; + j++,jj++,p++,pp++) { + in_v[l][pp] = in_v[i][p]; + in_v[i][jj] = in_v[l][j]; + } + for ( ; p <= n1-max(lbi,0); p++,pp++) + in_v[l][pp] = in_v[i][p]; + } + + if (lub%2 == 0) { /* shift only */ + i = lub/2; + for (j=max(i-lb,0), jj=0; jj <= n1-ub+i; j++,jj++) + in_v[i][jj] = in_v[i][j]; + } + } + else { /* ub < lb, hence ub-l <= 0 & lb-i >= 0 */ + int p,pp,ubi; + + for (i=0, l=lub; i < (lub+1)/2; i++,l--) { + ubi = i-ub; + for (j=n1-max(lb-l,0), jj=n1-max(-ubi,0), p=n1-lb+i, pp=n1; + p >= 0; j--, jj--, pp--, p--) { + in_v[i][jj] = in_v[l][j]; + in_v[l][pp] = in_v[i][p]; + } + for ( ; jj >= max(ubi,0); j--, jj--) + in_v[i][jj] = in_v[l][j]; + } + + if (lub%2 == 0) { /* shift only */ + i = lub/2; + for (j=n1-lb+i, jj=n1-max(ub-i,0); j >= 0; j--, jj--) + in_v[i][jj] = in_v[i][j]; + } + } + + return out; +} + + + +/* bdLUfactor -- gaussian elimination with partial pivoting + -- on entry, the matrix A in band storage with elements + in rows 0 to lb+ub; + The jth column of A is stored in the jth column of + band A (bA) as follows: + bA->mat->me[lb+j-i][j] = A->me[i][j] for + max(0,j-lb) <= i <= min(A->n-1,j+ub); + -- on exit: U is stored as an upper triangular matrix + with lb+ub superdiagonals in rows lb to 2*lb+ub, + and the matrix L is stored in rows 0 to lb-1. + Matrix U is permuted, whereas L is not permuted !!! + Therefore we save some memory. + */ +BAND *bdLUfactor(bA,pivot) +BAND *bA; +PERM *pivot; +{ + int i, j, k, l, n, n1, lb, ub, lub, k_end, k_lub; + int i_max, shift; + Real **bA_v; + Real max1, temp; + + if ( bA==(BAND *)NULL || pivot==(PERM *)NULL ) + error(E_NULL,"bdLUfactor"); + + lb = bA->lb; + ub = bA->ub; + lub = lb+ub; + n = bA->mat->n; + n1 = n-1; + lub = lb+ub; + + if ( pivot->size != n ) + error(E_SIZES,"bdLUfactor"); + + + /* initialise pivot with identity permutation */ + for ( i=0; i < n; i++ ) + pivot->pe[i] = i; + + /* extend band matrix */ + /* extended part is filled with zeros */ + bA = bd_resize(bA,lb,min(n1,lub),n); + bA_v = bA->mat->me; + + + /* main loop */ + + for ( k=0; k < n1; k++ ) + { + k_end = max(0,lb+k-n1); + k_lub = min(k+lub,n1); + + /* find the best pivot row */ + + max1 = 0.0; + i_max = -1; + for ( i=lb; i >= k_end; i-- ) { + temp = fabs(bA_v[i][k]); + if ( temp > max1 ) + { max1 = temp; i_max = i; } + } + + /* if no pivot then ignore column k... */ + if ( i_max == -1 ) + continue; + + /* do we pivot ? */ + if ( i_max != lb ) /* yes we do... */ + { + /* save transposition using non-shifted indices */ + shift = lb-i_max; + px_transp(pivot,k+shift,k); + for ( i=lb, j=k; j <= k_lub; i++,j++ ) + { + temp = bA_v[i][j]; + bA_v[i][j] = bA_v[i-shift][j]; + bA_v[i-shift][j] = temp; + } + } + + /* row operations */ + for ( i=lb-1; i >= k_end; i-- ) { + temp = bA_v[i][k] /= bA_v[lb][k]; + shift = lb-i; + for ( j=k+1,l=i+1; j <= k_lub; l++,j++ ) + bA_v[l][j] -= temp*bA_v[l+shift][j]; + } + } + + return bA; +} + + +/* bdLUsolve -- given an LU factorisation in bA, solve bA*x=b */ +/* pivot is changed upon return */ +VEC *bdLUsolve(bA,pivot,b,x) +BAND *bA; +PERM *pivot; +VEC *b,*x; +{ + int i,j,l,n,n1,pi,lb,ub,jmin, maxj; + Real c; + Real **bA_v; + + if ( bA==(BAND *)NULL || b==(VEC *)NULL || pivot==(PERM *)NULL ) + error(E_NULL,"bdLUsolve"); + if ( bA->mat->n != b->dim || bA->mat->n != pivot->size) + error(E_SIZES,"bdLUsolve"); + + lb = bA->lb; + ub = bA->ub; + n = b->dim; + n1 = n-1; + bA_v = bA->mat->me; + + x = v_resize(x,b->dim); + px_vec(pivot,b,x); + + /* solve Lx = b; implicit diagonal = 1 + L is not permuted, therefore it must be permuted now + */ + + px_inv(pivot,pivot); + for (j=0; j < n; j++) { + jmin = j+1; + c = x->ve[j]; + maxj = max(0,j+lb-n1); + for (i=jmin,l=lb-1; l >= maxj; i++,l--) { + if ( (pi = pivot->pe[i]) < jmin) + pi = pivot->pe[i] = pivot->pe[pi]; + x->ve[pi] -= bA_v[l][j]*c; + } + } + + /* solve Ux = b; explicit diagonal */ + + x->ve[n1] /= bA_v[lb][n1]; + for (i=n-2; i >= 0; i--) { + c = x->ve[i]; + for (j=min(n1,i+ub), l=lb+j-i; j > i; j--,l--) + c -= bA_v[l][j]*x->ve[j]; + x->ve[i] = c/bA_v[lb][i]; + } + + return (x); +} + +/* LDLfactor -- L.D.L' factorisation of A in-situ; + A is a band matrix + it works using only lower bandwidth & main diagonal + so it is possible to set A->ub = 0 + */ + +BAND *bdLDLfactor(A) +BAND *A; +{ + int i,j,k,n,n1,lb,ki,jk,ji,lbkm,lbkp; + Real **Av; + Real c, cc; + + if ( ! A ) + error(E_NULL,"bdLDLfactor"); + + if (A->lb == 0) return A; + + lb = A->lb; + n = A->mat->n; + n1 = n-1; + Av = A->mat->me; + + for (k=0; k < n; k++) { + lbkm = lb-k; + lbkp = lb+k; + + /* matrix D */ + c = Av[lb][k]; + for (j=max(0,-lbkm), jk=lbkm+j; j < k; j++, jk++) { + cc = Av[jk][j]; + c -= Av[lb][j]*cc*cc; + } + if (c == 0.0) + error(E_SING,"bdLDLfactor"); + Av[lb][k] = c; + + /* matrix L */ + + for (i=min(n1,lbkp), ki=lbkp-i; i > k; i--,ki++) { + c = Av[ki][k]; + for (j=max(0,i-lb), ji=lb+j-i, jk=lbkm+j; j < k; + j++, ji++, jk++) + c -= Av[lb][j]*Av[ji][j]*Av[jk][j]; + Av[ki][k] = c/Av[lb][k]; + } + } + + return A; +} + +/* solve A*x = b, where A is factorized by + Choleski LDL^T factorization */ +VEC *bdLDLsolve(A,b,x) +BAND *A; +VEC *b, *x; +{ + int i,j,l,n,n1,lb,ilb; + Real **Av, *Avlb; + Real c; + + if ( ! A || ! b ) + error(E_NULL,"bdLDLsolve"); + if ( A->mat->n != b->dim ) + error(E_SIZES,"bdLDLsolve"); + + n = A->mat->n; + n1 = n-1; + x = v_resize(x,n); + lb = A->lb; + Av = A->mat->me; + Avlb = Av[lb]; + + /* solve L*y = b */ + x->ve[0] = b->ve[0]; + for (i=1; i < n; i++) { + ilb = i-lb; + c = b->ve[i]; + for (j=max(0,ilb), l=j-ilb; j < i; j++,l++) + c -= Av[l][j]*x->ve[j]; + x->ve[i] = c; + } + + /* solve D*z = y */ + for (i=0; i < n; i++) + x->ve[i] /= Avlb[i]; + + /* solve L^T*x = z */ + for (i=n-2; i >= 0; i--) { + ilb = i+lb; + c = x->ve[i]; + for (j=min(n1,ilb), l=ilb-j; j > i; j--,l++) + c -= Av[l][i]*x->ve[j]; + x->ve[i] = c; + } + + return x; +} + + + diff --git a/meschach/bkpfacto.c b/meschach/bkpfacto.c new file mode 100644 index 0000000..394de11 --- /dev/null +++ b/meschach/bkpfacto.c @@ -0,0 +1,311 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Matrix factorisation routines to work with the other matrix files. +*/ + +static char rcsid[] = "$Id: bkpfacto.c,v 1.1 2001/03/01 17:18:31 rfranke Exp $"; + +#include +#include +#include "matrix.h" +#include "matrix2.h" + +#define btos(x) ((x) ? "TRUE" : "FALSE") + +/* Most matrix factorisation routines are in-situ unless otherwise specified */ + +#define alpha 0.6403882032022076 /* = (1+sqrt(17))/8 */ + +/* sqr -- returns square of x -- utility function */ +static double sqr(x) +double x; +{ return x*x; } + +/* interchange -- a row/column swap routine */ +static void interchange(A,i,j) +MAT *A; /* assumed != NULL & also SQUARE */ +int i, j; /* assumed in range */ +{ + Real **A_me, tmp; + int k, n; + + A_me = A->me; n = A->n; + if ( i == j ) + return; + if ( i > j ) + { k = i; i = j; j = k; } + for ( k = 0; k < i; k++ ) + { + /* tmp = A_me[k][i]; */ + tmp = m_entry(A,k,i); + /* A_me[k][i] = A_me[k][j]; */ + m_set_val(A,k,i,m_entry(A,k,j)); + /* A_me[k][j] = tmp; */ + m_set_val(A,k,j,tmp); + } + for ( k = j+1; k < n; k++ ) + { + /* tmp = A_me[j][k]; */ + tmp = m_entry(A,j,k); + /* A_me[j][k] = A_me[i][k]; */ + m_set_val(A,j,k,m_entry(A,i,k)); + /* A_me[i][k] = tmp; */ + m_set_val(A,i,k,tmp); + } + for ( k = i+1; k < j; k++ ) + { + /* tmp = A_me[k][j]; */ + tmp = m_entry(A,k,j); + /* A_me[k][j] = A_me[i][k]; */ + m_set_val(A,k,j,m_entry(A,i,k)); + /* A_me[i][k] = tmp; */ + m_set_val(A,i,k,tmp); + } + /* tmp = A_me[i][i]; */ + tmp = m_entry(A,i,i); + /* A_me[i][i] = A_me[j][j]; */ + m_set_val(A,i,i,m_entry(A,j,j)); + /* A_me[j][j] = tmp; */ + m_set_val(A,j,j,tmp); +} + +/* BKPfactor -- Bunch-Kaufman-Parlett factorisation of A in-situ + -- A is factored into the form P'AP = MDM' where + P is a permutation matrix, M lower triangular and D is block + diagonal with blocks of size 1 or 2 + -- P is stored in pivot; blocks[i]==i iff D[i][i] is a block */ +MAT *BKPfactor(A,pivot,blocks) +MAT *A; +PERM *pivot, *blocks; +{ + int i, j, k, n, onebyone, r; + Real **A_me, aii, aip1, aip1i, lambda, sigma, tmp; + Real det, s, t; + + if ( ! A || ! pivot || ! blocks ) + error(E_NULL,"BKPfactor"); + if ( A->m != A->n ) + error(E_SQUARE,"BKPfactor"); + if ( A->m != pivot->size || pivot->size != blocks->size ) + error(E_SIZES,"BKPfactor"); + + n = A->n; + A_me = A->me; + px_ident(pivot); px_ident(blocks); + + for ( i = 0; i < n; i = onebyone ? i+1 : i+2 ) + { + /* printf("# Stage: %d\n",i); */ + aii = fabs(m_entry(A,i,i)); + lambda = 0.0; r = (i+1 < n) ? i+1 : i; + for ( k = i+1; k < n; k++ ) + { + tmp = fabs(m_entry(A,i,k)); + if ( tmp >= lambda ) + { + lambda = tmp; + r = k; + } + } + /* printf("# lambda = %g, r = %d\n", lambda, r); */ + /* printf("# |A[%d][%d]| = %g\n",r,r,fabs(m_entry(A,r,r))); */ + + /* determine if 1x1 or 2x2 block, and do pivoting if needed */ + if ( aii >= alpha*lambda ) + { + onebyone = TRUE; + goto dopivot; + } + /* compute sigma */ + sigma = 0.0; + for ( k = i; k < n; k++ ) + { + if ( k == r ) + continue; + tmp = ( k > r ) ? fabs(m_entry(A,r,k)) : + fabs(m_entry(A,k,r)); + if ( tmp > sigma ) + sigma = tmp; + } + if ( aii*sigma >= alpha*sqr(lambda) ) + onebyone = TRUE; + else if ( fabs(m_entry(A,r,r)) >= alpha*sigma ) + { + /* printf("# Swapping rows/cols %d and %d\n",i,r); */ + interchange(A,i,r); + px_transp(pivot,i,r); + onebyone = TRUE; + } + else + { + /* printf("# Swapping rows/cols %d and %d\n",i+1,r); */ + interchange(A,i+1,r); + px_transp(pivot,i+1,r); + px_transp(blocks,i,i+1); + onebyone = FALSE; + } + /* printf("onebyone = %s\n",btos(onebyone)); */ + /* printf("# Matrix so far (@checkpoint A) =\n"); */ + /* m_output(A); */ + /* printf("# pivot =\n"); px_output(pivot); */ + /* printf("# blocks =\n"); px_output(blocks); */ + +dopivot: + if ( onebyone ) + { /* do one by one block */ + if ( m_entry(A,i,i) != 0.0 ) + { + aii = m_entry(A,i,i); + for ( j = i+1; j < n; j++ ) + { + tmp = m_entry(A,i,j)/aii; + for ( k = j; k < n; k++ ) + m_sub_val(A,j,k,tmp*m_entry(A,i,k)); + m_set_val(A,i,j,tmp); + } + } + } + else /* onebyone == FALSE */ + { /* do two by two block */ + det = m_entry(A,i,i)*m_entry(A,i+1,i+1)-sqr(m_entry(A,i,i+1)); + /* Must have det < 0 */ + /* printf("# det = %g\n",det); */ + aip1i = m_entry(A,i,i+1)/det; + aii = m_entry(A,i,i)/det; + aip1 = m_entry(A,i+1,i+1)/det; + for ( j = i+2; j < n; j++ ) + { + s = - aip1i*m_entry(A,i+1,j) + aip1*m_entry(A,i,j); + t = - aip1i*m_entry(A,i,j) + aii*m_entry(A,i+1,j); + for ( k = j; k < n; k++ ) + m_sub_val(A,j,k,m_entry(A,i,k)*s + m_entry(A,i+1,k)*t); + m_set_val(A,i,j,s); + m_set_val(A,i+1,j,t); + } + } + /* printf("# Matrix so far (@checkpoint B) =\n"); */ + /* m_output(A); */ + /* printf("# pivot =\n"); px_output(pivot); */ + /* printf("# blocks =\n"); px_output(blocks); */ + } + + /* set lower triangular half */ + for ( i = 0; i < A->m; i++ ) + for ( j = 0; j < i; j++ ) + m_set_val(A,i,j,m_entry(A,j,i)); + + return A; +} + +/* BKPsolve -- solves A.x = b where A has been factored a la BKPfactor() + -- returns x, which is created if NULL */ +VEC *BKPsolve(A,pivot,block,b,x) +MAT *A; +PERM *pivot, *block; +VEC *b, *x; +{ + static VEC *tmp=VNULL; /* dummy storage needed */ + int i, j, n, onebyone; + Real **A_me, a11, a12, a22, b1, b2, det, sum, *tmp_ve, tmp_diag; + + if ( ! A || ! pivot || ! block || ! b ) + error(E_NULL,"BKPsolve"); + if ( A->m != A->n ) + error(E_SQUARE,"BKPsolve"); + n = A->n; + if ( b->dim != n || pivot->size != n || block->size != n ) + error(E_SIZES,"BKPsolve"); + x = v_resize(x,n); + tmp = v_resize(tmp,n); + MEM_STAT_REG(tmp,TYPE_VEC); + + A_me = A->me; tmp_ve = tmp->ve; + + px_vec(pivot,b,tmp); + /* solve for lower triangular part */ + for ( i = 0; i < n; i++ ) + { + sum = v_entry(tmp,i); + if ( block->pe[i] < i ) + for ( j = 0; j < i-1; j++ ) + sum -= m_entry(A,i,j)*v_entry(tmp,j); + else + for ( j = 0; j < i; j++ ) + sum -= m_entry(A,i,j)*v_entry(tmp,j); + v_set_val(tmp,i,sum); + } + /* printf("# BKPsolve: solving L part: tmp =\n"); v_output(tmp); */ + /* solve for diagonal part */ + for ( i = 0; i < n; i = onebyone ? i+1 : i+2 ) + { + onebyone = ( block->pe[i] == i ); + if ( onebyone ) + { + tmp_diag = m_entry(A,i,i); + if ( tmp_diag == 0.0 ) + error(E_SING,"BKPsolve"); + /* tmp_ve[i] /= tmp_diag; */ + v_set_val(tmp,i,v_entry(tmp,i) / tmp_diag); + } + else + { + a11 = m_entry(A,i,i); + a22 = m_entry(A,i+1,i+1); + a12 = m_entry(A,i+1,i); + b1 = v_entry(tmp,i); b2 = v_entry(tmp,i+1); + det = a11*a22-a12*a12; /* < 0 : see BKPfactor() */ + if ( det == 0.0 ) + error(E_SING,"BKPsolve"); + det = 1/det; + v_set_val(tmp,i,det*(a22*b1-a12*b2)); + v_set_val(tmp,i+1,det*(a11*b2-a12*b1)); + } + } + /* printf("# BKPsolve: solving D part: tmp =\n"); v_output(tmp); */ + /* solve for transpose of lower traingular part */ + for ( i = n-1; i >= 0; i-- ) + { /* use symmetry of factored form to get stride 1 */ + sum = v_entry(tmp,i); + if ( block->pe[i] > i ) + for ( j = i+2; j < n; j++ ) + sum -= m_entry(A,i,j)*v_entry(tmp,j); + else + for ( j = i+1; j < n; j++ ) + sum -= m_entry(A,i,j)*v_entry(tmp,j); + v_set_val(tmp,i,sum); + } + + /* printf("# BKPsolve: solving L^T part: tmp =\n");v_output(tmp); */ + /* and do final permutation */ + x = pxinv_vec(pivot,tmp,x); + + return x; +} + + + diff --git a/meschach/chfactor.c b/meschach/chfactor.c new file mode 100644 index 0000000..1e1928a --- /dev/null +++ b/meschach/chfactor.c @@ -0,0 +1,217 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Matrix factorisation routines to work with the other matrix files. +*/ + +/* CHfactor.c 1.2 11/25/87 */ +static char rcsid[] = "$Id: chfactor.c,v 1.1 2001/03/01 17:18:32 rfranke Exp $"; + +#include +#include +#include "matrix.h" +#include "matrix2.h" + + +/* Most matrix factorisation routines are in-situ unless otherwise specified */ + +/* CHfactor -- Cholesky L.L' factorisation of A in-situ */ +MAT *CHfactor(A) +MAT *A; +{ + u_int i, j, k, n; + Real **A_ent, *A_piv, *A_row, sum, tmp; + + if ( A==(MAT *)NULL ) + error(E_NULL,"CHfactor"); + if ( A->m != A->n ) + error(E_SQUARE,"CHfactor"); + n = A->n; A_ent = A->me; + + for ( k=0; km != A->n || A->n != b->dim ) + error(E_SIZES,"CHsolve"); + x = v_resize(x,b->dim); + Lsolve(A,b,x,0.0); + Usolve(A,x,x,0.0); + + return (x); +} + +/* LDLfactor -- L.D.L' factorisation of A in-situ */ +MAT *LDLfactor(A) +MAT *A; +{ + u_int i, k, n, p; + Real **A_ent; + Real d, sum; + static VEC *r = VNULL; + + if ( ! A ) + error(E_NULL,"LDLfactor"); + if ( A->m != A->n ) + error(E_SQUARE,"LDLfactor"); + n = A->n; A_ent = A->me; + r = v_resize(r,n); + MEM_STAT_REG(r,TYPE_VEC); + + for ( k = 0; k < n; k++ ) + { + sum = 0.0; + for ( p = 0; p < k; p++ ) + { + r->ve[p] = A_ent[p][p]*A_ent[k][p]; + sum += r->ve[p]*A_ent[k][p]; + } + d = A_ent[k][k] -= sum; + + if ( d == 0.0 ) + error(E_SING,"LDLfactor"); + for ( i = k+1; i < n; i++ ) + { + sum = __ip__(A_ent[i],r->ve,(int)k); + /**************************************** + sum = 0.0; + for ( p = 0; p < k; p++ ) + sum += A_ent[i][p]*r->ve[p]; + ****************************************/ + A_ent[i][k] = (A_ent[i][k] - sum)/d; + } + } + + return A; +} + +VEC *LDLsolve(LDL,b,x) +MAT *LDL; +VEC *b, *x; +{ + if ( ! LDL || ! b ) + error(E_NULL,"LDLsolve"); + if ( LDL->m != LDL->n ) + error(E_SQUARE,"LDLsolve"); + if ( LDL->m != b->dim ) + error(E_SIZES,"LDLsolve"); + x = v_resize(x,b->dim); + + Lsolve(LDL,b,x,1.0); + Dsolve(LDL,x,x); + LTsolve(LDL,x,x,1.0); + + return x; +} + +/* MCHfactor -- Modified Cholesky L.L' factorisation of A in-situ */ +MAT *MCHfactor(A,tol) +MAT *A; +double tol; +{ + u_int i, j, k, n; + Real **A_ent, *A_piv, *A_row, sum, tmp; + + if ( A==(MAT *)NULL ) + error(E_NULL,"MCHfactor"); + if ( A->m != A->n ) + error(E_SQUARE,"MCHfactor"); + if ( tol <= 0.0 ) + error(E_RANGE,"MCHfactor"); + n = A->n; A_ent = A->me; + + for ( k=0; k +#include +#include "matrix.h" +#include "sparse.h" +static char rcsid[] = "$Id: conjgrad.c,v 1.1 2001/03/01 17:18:33 rfranke Exp $"; + + +/* #define MAX_ITER 10000 */ +static int max_iter = 10000; +int cg_num_iters; + +/* matrix-as-routine type definition */ +/* #ifdef ANSI_C */ +/* typedef VEC *(*MTX_FN)(void *params, VEC *x, VEC *out); */ +/* #else */ +typedef VEC *(*MTX_FN)(); +/* #endif */ +#ifdef ANSI_C +VEC *spCHsolve(SPMAT *,VEC *,VEC *); +#else +VEC *spCHsolve(); +#endif + +/* cg_set_maxiter -- sets maximum number of iterations if numiter > 1 + -- just returns current max_iter otherwise + -- returns old maximum */ +int cg_set_maxiter(numiter) +int numiter; +{ + int temp; + + if ( numiter < 2 ) + return max_iter; + temp = max_iter; + max_iter = numiter; + return temp; +} + + +/* pccg -- solves A.x = b using pre-conditioner M + (assumed factored a la spCHfctr()) + -- results are stored in x (if x != NULL), which is returned */ +VEC *pccg(A,A_params,M_inv,M_params,b,eps,x) +MTX_FN A, M_inv; +VEC *b, *x; +double eps; +void *A_params, *M_params; +{ + VEC *r = VNULL, *p = VNULL, *q = VNULL, *z = VNULL; + int k; + Real alpha, beta, ip, old_ip, norm_b; + + if ( ! A || ! b ) + error(E_NULL,"pccg"); + if ( x == b ) + error(E_INSITU,"pccg"); + x = v_resize(x,b->dim); + if ( eps <= 0.0 ) + eps = MACHEPS; + + r = v_get(b->dim); + p = v_get(b->dim); + q = v_get(b->dim); + z = v_get(b->dim); + + norm_b = v_norm2(b); + + v_zero(x); + r = v_copy(b,r); + old_ip = 0.0; + for ( k = 0; ; k++ ) + { + if ( v_norm2(r) < eps*norm_b ) + break; + if ( k > max_iter ) + error(E_ITER,"pccg"); + if ( M_inv ) + (*M_inv)(M_params,r,z); + else + v_copy(r,z); /* M == identity */ + ip = in_prod(z,r); + if ( k ) /* if ( k > 0 ) ... */ + { + beta = ip/old_ip; + p = v_mltadd(z,p,beta,p); + } + else /* if ( k == 0 ) ... */ + { + beta = 0.0; + p = v_copy(z,p); + old_ip = 0.0; + } + q = (*A)(A_params,p,q); + alpha = ip/in_prod(p,q); + x = v_mltadd(x,p,alpha,x); + r = v_mltadd(r,q,-alpha,r); + old_ip = ip; + } + cg_num_iters = k; + + V_FREE(p); + V_FREE(q); + V_FREE(r); + V_FREE(z); + + return x; +} + +/* sp_pccg -- a simple interface to pccg() which uses sparse matrix + data structures + -- assumes that LLT contains the Cholesky factorisation of the + actual pre-conditioner */ +VEC *sp_pccg(A,LLT,b,eps,x) +SPMAT *A, *LLT; +VEC *b, *x; +double eps; +{ return pccg(sp_mv_mlt,A,spCHsolve,LLT,b,eps,x); } + + +/* + Routines for performing the CGS (Conjugate Gradient Squared) + algorithm of P. Sonneveld: + "CGS, a fast Lanczos-type solver for nonsymmetric linear + systems", SIAM J. Sci. & Stat. Comp. v. 10, pp. 36--52 +*/ + +/* cgs -- uses CGS to compute a solution x to A.x=b + -- the matrix A is not passed explicitly, rather a routine + A is passed where A(x,Ax,params) computes + Ax = A.x + -- the computed solution is passed */ +VEC *cgs(A,A_params,b,r0,tol,x) +MTX_FN A; +VEC *x, *b; +VEC *r0; /* tilde r0 parameter -- should be random??? */ +double tol; /* error tolerance used */ +void *A_params; +{ + VEC *p, *q, *r, *u, *v, *tmp1, *tmp2; + Real alpha, beta, norm_b, rho, old_rho, sigma; + int iter; + + if ( ! A || ! x || ! b || ! r0 ) + error(E_NULL,"cgs"); + if ( x->dim != b->dim || r0->dim != x->dim ) + error(E_SIZES,"cgs"); + if ( tol <= 0.0 ) + tol = MACHEPS; + + p = v_get(x->dim); + q = v_get(x->dim); + r = v_get(x->dim); + u = v_get(x->dim); + v = v_get(x->dim); + tmp1 = v_get(x->dim); + tmp2 = v_get(x->dim); + + norm_b = v_norm2(b); + (*A)(A_params,x,tmp1); + v_sub(b,tmp1,r); + v_zero(p); v_zero(q); + old_rho = 1.0; + + iter = 0; + while ( v_norm2(r) > tol*norm_b ) + { + if ( ++iter > max_iter ) break; + /* error(E_ITER,"cgs"); */ + rho = in_prod(r0,r); + if ( old_rho == 0.0 ) + error(E_SING,"cgs"); + beta = rho/old_rho; + v_mltadd(r,q,beta,u); + v_mltadd(q,p,beta,tmp1); + v_mltadd(u,tmp1,beta,p); + + (*A)(A_params,p,v); + + sigma = in_prod(r0,v); + if ( sigma == 0.0 ) + error(E_SING,"cgs"); + alpha = rho/sigma; + v_mltadd(u,v,-alpha,q); + v_add(u,q,tmp1); + + (*A)(A_params,tmp1,tmp2); + + v_mltadd(r,tmp2,-alpha,r); + v_mltadd(x,tmp1,alpha,x); + + old_rho = rho; + } + cg_num_iters = iter; + + V_FREE(p); V_FREE(q); V_FREE(r); + V_FREE(u); V_FREE(v); + V_FREE(tmp1); V_FREE(tmp2); + + return x; +} + +/* sp_cgs -- simple interface for SPMAT data structures */ +VEC *sp_cgs(A,b,r0,tol,x) +SPMAT *A; +VEC *b, *r0, *x; +double tol; +{ return cgs(sp_mv_mlt,A,b,r0,tol,x); } + +/* + Routine for performing LSQR -- the least squares QR algorithm + of Paige and Saunders: + "LSQR: an algorithm for sparse linear equations and + sparse least squares", ACM Trans. Math. Soft., v. 8 + pp. 43--71 (1982) +*/ +/* lsqr -- sparse CG-like least squares routine: + -- finds min_x ||A.x-b||_2 using A defined through A & AT + -- returns x (if x != NULL) */ +VEC *lsqr(A,AT,A_params,b,tol,x) +MTX_FN A, AT; /* AT is A transposed */ +VEC *x, *b; +double tol; /* error tolerance used */ +void *A_params; +{ + VEC *u, *v, *w, *tmp; + Real alpha, beta, norm_b, phi, phi_bar, + rho, rho_bar, rho_max, theta; + Real s, c; /* for Givens' rotations */ + int iter, m, n; + + if ( ! b || ! x ) + error(E_NULL,"lsqr"); + if ( tol <= 0.0 ) + tol = MACHEPS; + + m = b->dim; n = x->dim; + u = v_get((u_int)m); + v = v_get((u_int)n); + w = v_get((u_int)n); + tmp = v_get((u_int)n); + norm_b = v_norm2(b); + + v_zero(x); + beta = v_norm2(b); + if ( beta == 0.0 ) + return x; + sv_mlt(1.0/beta,b,u); + tracecatch((*AT)(A_params,u,v),"lsqr"); + alpha = v_norm2(v); + if ( alpha == 0.0 ) + return x; + sv_mlt(1.0/alpha,v,v); + v_copy(v,w); + phi_bar = beta; rho_bar = alpha; + + rho_max = 1.0; + iter = 0; + do { + if ( ++iter > max_iter ) + error(E_ITER,"lsqr"); + + tmp = v_resize(tmp,m); + tracecatch((*A) (A_params,v,tmp),"lsqr"); + + v_mltadd(tmp,u,-alpha,u); + beta = v_norm2(u); sv_mlt(1.0/beta,u,u); + + tmp = v_resize(tmp,n); + tracecatch((*AT)(A_params,u,tmp),"lsqr"); + v_mltadd(tmp,v,-beta,v); + alpha = v_norm2(v); sv_mlt(1.0/alpha,v,v); + + rho = sqrt(rho_bar*rho_bar+beta*beta); + if ( rho > rho_max ) + rho_max = rho; + c = rho_bar/rho; + s = beta/rho; + theta = s*alpha; + rho_bar = -c*alpha; + phi = c*phi_bar; + phi_bar = s*phi_bar; + + /* update x & w */ + if ( rho == 0.0 ) + error(E_SING,"lsqr"); + v_mltadd(x,w,phi/rho,x); + v_mltadd(v,w,-theta/rho,w); + } while ( fabs(phi_bar*alpha*c) > tol*norm_b/rho_max ); + + cg_num_iters = iter; + + V_FREE(tmp); V_FREE(u); V_FREE(v); V_FREE(w); + + return x; +} + +/* sp_lsqr -- simple interface for SPMAT data structures */ +VEC *sp_lsqr(A,b,tol,x) +SPMAT *A; +VEC *b, *x; +double tol; +{ return lsqr(sp_mv_mlt,sp_vm_mlt,A,b,tol,x); } + diff --git a/meschach/copy.c b/meschach/copy.c new file mode 100644 index 0000000..c6162ae --- /dev/null +++ b/meschach/copy.c @@ -0,0 +1,210 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +static char rcsid[] = "$Id: copy.c,v 1.1 2001/03/01 17:18:33 rfranke Exp $"; +#include +#include "matrix.h" + + + +/* _m_copy -- copies matrix into new area */ +MAT *_m_copy(in,out,i0,j0) +MAT *in,*out; +u_int i0,j0; +{ + u_int i /* ,j */; + + if ( in==MNULL ) + error(E_NULL,"_m_copy"); + if ( in==out ) + return (out); + if ( out==MNULL || out->m != in->m || out->n != in->n ) + out = m_resize(out,in->m,in->n); + + for ( i=i0; i < in->m; i++ ) + MEM_COPY(&(in->me[i][j0]),&(out->me[i][j0]), + (in->n - j0)*sizeof(Real)); + /* for ( j=j0; j < in->n; j++ ) + out->me[i][j] = in->me[i][j]; */ + + return (out); +} + +/* _v_copy -- copies vector into new area */ +VEC *_v_copy(in,out,i0) +VEC *in,*out; +u_int i0; +{ + /* u_int i,j; */ + + if ( in==VNULL ) + error(E_NULL,"_v_copy"); + if ( in==out ) + return (out); + if ( out==VNULL || out->dim != in->dim ) + out = v_resize(out,in->dim); + + MEM_COPY(&(in->ve[i0]),&(out->ve[i0]),(in->dim - i0)*sizeof(Real)); + /* for ( i=i0; i < in->dim; i++ ) + out->ve[i] = in->ve[i]; */ + + return (out); +} + +/* px_copy -- copies permutation 'in' to 'out' */ +PERM *px_copy(in,out) +PERM *in,*out; +{ + /* int i; */ + + if ( in == PNULL ) + error(E_NULL,"px_copy"); + if ( in == out ) + return out; + if ( out == PNULL || out->size != in->size ) + out = px_resize(out,in->size); + + MEM_COPY(in->pe,out->pe,in->size*sizeof(u_int)); + /* for ( i = 0; i < in->size; i++ ) + out->pe[i] = in->pe[i]; */ + + return out; +} + +/* + The .._move() routines are for moving blocks of memory around + within Meschach data structures and for re-arranging matrices, + vectors etc. +*/ + +/* m_move -- copies selected pieces of a matrix + -- moves the m0 x n0 submatrix with top-left cor-ordinates (i0,j0) + to the corresponding submatrix of out with top-left co-ordinates + (i1,j1) + -- out is resized (& created) if necessary */ +MAT *m_move(in,i0,j0,m0,n0,out,i1,j1) +MAT *in, *out; +int i0, j0, m0, n0, i1, j1; +{ + int i; + + if ( ! in ) + error(E_NULL,"m_move"); + if ( i0 < 0 || j0 < 0 || i1 < 0 || j1 < 0 || m0 < 0 || n0 < 0 || + i0+m0 > in->m || j0+n0 > in->n ) + error(E_BOUNDS,"m_move"); + + if ( ! out ) + out = m_resize(out,i1+m0,j1+n0); + else if ( i1+m0 > out->m || j1+n0 > out->n ) + out = m_resize(out,max(out->m,i1+m0),max(out->n,j1+n0)); + + for ( i = 0; i < m0; i++ ) + MEM_COPY(&(in->me[i0+i][j0]),&(out->me[i1+i][j1]), + n0*sizeof(Real)); + + return out; +} + +/* v_move -- copies selected pieces of a vector + -- moves the length dim0 subvector with initial index i0 + to the corresponding subvector of out with initial index i1 + -- out is resized if necessary */ +VEC *v_move(in,i0,dim0,out,i1) +VEC *in, *out; +int i0, dim0, i1; +{ + if ( ! in ) + error(E_NULL,"v_move"); + if ( i0 < 0 || dim0 < 0 || i1 < 0 || + i0+dim0 > in->dim ) + error(E_BOUNDS,"v_move"); + + if ( (! out) || i1+dim0 > out->dim ) + out = v_resize(out,i1+dim0); + + MEM_COPY(&(in->ve[i0]),&(out->ve[i1]),dim0*sizeof(Real)); + + return out; +} + +/* mv_move -- copies selected piece of matrix to a vector + -- moves the m0 x n0 submatrix with top-left co-ordinate (i0,j0) to + the subvector with initial index i1 (and length m0*n0) + -- rows are copied contiguously + -- out is resized if necessary */ +VEC *mv_move(in,i0,j0,m0,n0,out,i1) +MAT *in; +VEC *out; +int i0, j0, m0, n0, i1; +{ + int dim1, i; + + if ( ! in ) + error(E_NULL,"mv_move"); + if ( i0 < 0 || j0 < 0 || m0 < 0 || n0 < 0 || i1 < 0 || + i0+m0 > in->m || j0+n0 > in->n ) + error(E_BOUNDS,"mv_move"); + + dim1 = m0*n0; + if ( (! out) || i1+dim1 > out->dim ) + out = v_resize(out,i1+dim1); + + for ( i = 0; i < m0; i++ ) + MEM_COPY(&(in->me[i0+i][j0]),&(out->ve[i1+i*n0]),n0*sizeof(Real)); + + return out; +} + +/* vm_move -- copies selected piece of vector to a matrix + -- moves the subvector with initial index i0 and length m1*n1 to + the m1 x n1 submatrix with top-left co-ordinate (i1,j1) + -- copying is done by rows + -- out is resized if necessary */ +MAT *vm_move(in,i0,out,i1,j1,m1,n1) +VEC *in; +MAT *out; +int i0, i1, j1, m1, n1; +{ + int dim0, i; + + if ( ! in ) + error(E_NULL,"vm_move"); + if ( i0 < 0 || i1 < 0 || j1 < 0 || m1 < 0 || n1 < 0 || + i0+m1*n1 > in->dim ) + error(E_BOUNDS,"vm_move"); + + if ( ! out ) + out = m_resize(out,i1+m1,j1+n1); + else + out = m_resize(out,max(i1+m1,out->m),max(j1+n1,out->n)); + + dim0 = m1*n1; + for ( i = 0; i < m1; i++ ) + MEM_COPY(&(in->ve[i0+i*n1]),&(out->me[i1+i][j1]),n1*sizeof(Real)); + + return out; +} diff --git a/meschach/dmacheps.c b/meschach/dmacheps.c new file mode 100644 index 0000000..2574fa9 --- /dev/null +++ b/meschach/dmacheps.c @@ -0,0 +1,46 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +#include + +double dclean(x) +double x; +{ + static double y; + y = x; + return y; /* prevents optimisation */ +} + +main() +{ + static double deps, deps1, dtmp; + + deps = 1.0; + while ( dclean(1.0+deps) > 1.0 ) + deps = 0.5*deps; + + printf("%g\n", 2.0*deps); +} diff --git a/meschach/err.c b/meschach/err.c new file mode 100644 index 0000000..a81c56c --- /dev/null +++ b/meschach/err.c @@ -0,0 +1,338 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + File with basic error-handling operations + Based on previous version on Zilog + System 8000 setret() etc. + Ported to Pyramid 9810 late 1987 + */ + +static char rcsid[] = "$Id: err.c,v 1.1 2001/03/01 17:18:34 rfranke Exp $"; + +#include +#include +#include +#include "m_err.h" + + +#ifdef SYSV +/* AT&T System V */ +#include +#else +/* something else -- assume BSD or ANSI C */ +#include +#endif + + + +#define FALSE 0 +#define TRUE 1 + +#define EF_EXIT 0 +#define EF_ABORT 1 +#define EF_JUMP 2 +#define EF_SILENT 3 + +/* The only error caught in this file! */ +#define E_SIGNAL 16 + +static char *err_mesg[] = +{ "unknown error", /* 0 */ + "sizes of objects don't match", /* 1 */ + "index out of bounds", /* 2 */ + "can't allocate memory", /* 3 */ + "singular matrix", /* 4 */ + "matrix not positive definite", /* 5 */ + "incorrect format input", /* 6 */ + "bad input file/device", /* 7 */ + "NULL objects passed", /* 8 */ + "matrix not square", /* 9 */ + "object out of range", /* 10 */ + "can't do operation in situ for non-square matrix", /* 11 */ + "can't do operation in situ", /* 12 */ + "excessive number of iterations", /* 13 */ + "convergence criterion failed", /* 14 */ + "bad starting value", /* 15 */ + "floating exception", /* 16 */ + "internal inconsistency (data structure)",/* 17 */ + "unexpected end-of-file", /* 18 */ + "shared vectors (cannot release them)", /* 19 */ + "negative argument", /* 20 */ + "cannot overwrite object" /* 21 */ + }; + +#define MAXERR (sizeof(err_mesg)/sizeof(char *)) + +static char *warn_mesg[] = { + "unknown warning", /* 0 */ + "wrong type number (use macro TYPE_*)", /* 1 */ + "no corresponding mem_stat_mark", /* 2 */ + "computed norm of a residual is less than 0", /* 3 */ + "resizing a shared vector" /* 4 */ +}; + +#define MAXWARN (sizeof(warn_mesg)/sizeof(char *)) + + + +#define MAX_ERRS 100 + +jmp_buf restart; + + +/* array of pointers to lists of errors */ + +typedef struct { + char **listp; /* pointer to a list of errors */ + unsigned len; /* length of the list */ + unsigned warn; /* =FALSE - errors, =TRUE - warnings */ +} Err_list; + +static Err_list err_list[ERR_LIST_MAX_LEN] = { + {err_mesg,MAXERR,FALSE}, /* basic errors list */ + {warn_mesg,MAXWARN,TRUE} /* basic warnings list */ +}; + + +static int err_list_end = 2; /* number of elements in err_list */ + +/* attach a new list of errors pointed by err_ptr + or change a previous one; + list_len is the number of elements in the list; + list_num is the list number; + warn == FALSE - errors (stop the program), + warn == TRUE - warnings (continue the program); + Note: lists numbered 0 and 1 are attached automatically, + you do not need to do it + */ +int err_list_attach(list_num, list_len,err_ptr,warn) +int list_num, list_len, warn; +char **err_ptr; +{ + if (list_num < 0 || list_len <= 0 || + err_ptr == (char **)NULL) + return -1; + + if (list_num >= ERR_LIST_MAX_LEN) { + fprintf(stderr,"\n file \"%s\": %s %s\n", + "err.c","increase the value of ERR_LIST_MAX_LEN", + "in matrix.h and zmatdef.h"); + if ( ! isatty(fileno(stdout)) ) + fprintf(stderr,"\n file \"%s\": %s %s\n", + "err.c","increase the value of ERR_LIST_MAX_LEN", + "in matrix.h and zmatdef.h"); + printf("Exiting program\n"); + exit(0); + } + + if (err_list[list_num].listp != (char **)NULL && + err_list[list_num].listp != err_ptr) + free((char *)err_list[list_num].listp); + err_list[list_num].listp = err_ptr; + err_list[list_num].len = list_len; + err_list[list_num].warn = warn; + err_list_end = list_num+1; + + return list_num; +} + + +/* release the error list numbered list_num */ +int err_list_free(list_num) +int list_num; +{ + if (list_num < 0 || list_num >= err_list_end) return -1; + if (err_list[list_num].listp != (char **)NULL) { + err_list[list_num].listp = (char **)NULL; + err_list[list_num].len = 0; + err_list[list_num].warn = 0; + } + return 0; +} + + +/* check if list_num is attached; + return FALSE if not; + return TRUE if yes + */ +int err_is_list_attached(list_num) +int list_num; +{ + if (list_num < 0 || list_num >= err_list_end) + return FALSE; + + if (err_list[list_num].listp != (char **)NULL) + return TRUE; + + return FALSE; +} + +/* other local variables */ + +static int err_flag = EF_EXIT, num_errs = 0, cnt_errs = 1; + +/* set_err_flag -- sets err_flag -- returns old err_flag */ +int set_err_flag(flag) +int flag; +{ + int tmp; + + tmp = err_flag; + err_flag = flag; + return tmp; +} + +/* count_errs -- sets cnt_errs (TRUE/FALSE) & returns old value */ +int count_errs(flag) +int flag; +{ + int tmp; + + tmp = cnt_errs; + cnt_errs = flag; + return tmp; +} + +/* ev_err -- reports error (err_num) in file "file" at line "line_num" and + returns to user error handler; + list_num is an error list number (0 is the basic list + pointed by err_mesg, 1 is the basic list of warnings) + */ +int ev_err(file,err_num,line_num,fn_name,list_num) +char *file, *fn_name; +int err_num, line_num,list_num; +{ + int num; + + if ( err_num < 0 ) err_num = 0; + + if (list_num < 0 || list_num >= err_list_end || + err_list[list_num].listp == (char **)NULL) { + fprintf(stderr, + "\n Not (properly) attached list of errors: list_num = %d\n", + list_num); + fprintf(stderr," Call \"err_list_attach\" in your program\n"); + if ( ! isatty(fileno(stdout)) ) { + fprintf(stderr, + "\n Not (properly) attached list of errors: list_num = %d\n", + list_num); + fprintf(stderr," Call \"err_list_attach\" in your program\n"); + } + printf("\nExiting program\n"); + exit(0); + } + + num = err_num; + if ( num >= err_list[list_num].len ) num = 0; + + if ( cnt_errs && ++num_errs >= MAX_ERRS ) /* too many errors */ + { + fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n", + file,line_num,err_list[list_num].listp[num], + isascii(*fn_name) ? fn_name : "???"); + if ( ! isatty(fileno(stdout)) ) + fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n", + file,line_num,err_list[list_num].listp[num], + isascii(*fn_name) ? fn_name : "???"); + printf("Sorry, too many errors: %d\n",num_errs); + printf("Exiting program\n"); + exit(0); + } + if ( err_list[list_num].warn ) + switch ( err_flag ) + { + case EF_SILENT: break; + default: + fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n\n", + file,line_num,err_list[list_num].listp[num], + isascii(*fn_name) ? fn_name : "???"); + if ( ! isatty(fileno(stdout)) ) + fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n\n", + file,line_num,err_list[list_num].listp[num], + isascii(*fn_name) ? fn_name : "???"); + break; + } + else + switch ( err_flag ) + { + case EF_SILENT: + longjmp(restart,(err_num==0)? -1 : err_num); + break; + case EF_ABORT: + fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n", + file,line_num,err_list[list_num].listp[num], + isascii(*fn_name) ? fn_name : "???"); + if ( ! isatty(fileno(stdout)) ) + fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n", + file,line_num,err_list[list_num].listp[num], + isascii(*fn_name) ? fn_name : "???"); + abort(); + break; + case EF_JUMP: + fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n", + file,line_num,err_list[list_num].listp[num], + isascii(*fn_name) ? fn_name : "???"); + if ( ! isatty(fileno(stdout)) ) + fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n", + file,line_num,err_list[list_num].listp[num], + isascii(*fn_name) ? fn_name : "???"); + longjmp(restart,(err_num==0)? -1 : err_num); + break; + default: + fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n\n", + file,line_num,err_list[list_num].listp[num], + isascii(*fn_name) ? fn_name : "???"); + if ( ! isatty(fileno(stdout)) ) + fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n\n", + file,line_num,err_list[list_num].listp[num], + isascii(*fn_name) ? fn_name : "???"); + + break; + } + + /* ensure exit if fall through */ + if ( ! err_list[list_num].warn ) exit(0); + + return 0; +} + +/* float_error -- catches floating arithmetic signals */ +static void float_error(num) +int num; +{ + signal(SIGFPE,float_error); + /* fprintf(stderr,"SIGFPE: signal #%d\n",num); */ + /* fprintf(stderr,"errno = %d\n",errno); */ + ev_err("???.c",E_SIGNAL,0,"???",0); +} + +/* catch_signal -- sets up float_error() to catch SIGFPE's */ +void catch_FPE() +{ + signal(SIGFPE,float_error); +} + diff --git a/meschach/extras.c b/meschach/extras.c new file mode 100644 index 0000000..9c685e0 --- /dev/null +++ b/meschach/extras.c @@ -0,0 +1,500 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Memory port routines: MEM_COPY and MEM_ZERO +*/ + +/* For BSD 4.[23] environments: using bcopy() and bzero() */ + +#include "machine.h" + +#ifndef MEM_COPY +void MEM_COPY(from,to,len) +char *from, *to; +int len; +{ + int i; + + if ( from < to ) + { + for ( i = 0; i < len; i++ ) + *to++ = *from++; + } + else + { + from += len; to += len; + for ( i = 0; i < len; i++ ) + *(--to) = *(--from); + } +} +#endif + +#ifndef MEM_ZERO +void MEM_ZERO(ptr,len) +char *ptr; +int len; +{ + int i; + + for ( i = 0; i < len; i++ ) + *(ptr++) = '\0'; +} +#endif + +/* + This file contains versions of something approximating the well-known + BLAS routines in C, suitable for Meschach (hence the `m'). + These are "vanilla" implementations, at least with some consideration + of the effects of caching and paging, and maybe some loop unrolling + for register-rich machines +*/ + +/* + Organisation of matrices: it is assumed that matrices are represented + by Real **'s. To keep flexibility, there is also an "initial + column" parameter j0, so that the actual elements used are + A[0][j0], A[0][j0+1], ..., A[0][j0+n-1] + A[1][j0], A[1][j0+1], ..., A[1][j0+n-1] + .. .. ... .. + A[m-1][j0], A[m-1][j0+1], ..., A[m-1][j0+n-1] +*/ + +static char rcsid[] = "$Id: extras.c,v 1.1 2001/03/01 17:18:34 rfranke Exp $"; + +#include + +#define REGISTER_RICH 1 + +/* mblar-1 routines */ + +/* Mscale -- sets x <- alpha.x */ +void Mscale(len,alpha,x) +int len; +double alpha; +Real *x; +{ + register int i; + + for ( i = 0; i < len; i++ ) + x[i] *= alpha; +} + +/* Mswap -- swaps x and y */ +void Mswap(len,x,y) +int len; +Real *x, *y; +{ + register int i; + register Real tmp; + + for ( i = 0; i < len; i++ ) + { + tmp = x[i]; + x[i] = y[i]; + y[i] = tmp; + } +} + +/* Mcopy -- copies x to y */ +void Mcopy(len,x,y) +int len; +Real *x, *y; +{ + register int i; + + for ( i = 0; i < len; i++ ) + y[i] = x[i]; +} + +/* Maxpy -- y <- y + alpha.x */ +void Maxpy(len,alpha,x,y) +int len; +double alpha; +Real *x, *y; +{ + register int i, len4; + + /**************************************** + for ( i = 0; i < len; i++ ) + y[i] += alpha*x[i]; + ****************************************/ + +#ifdef REGISTER_RICH + len4 = len / 4; + len = len % 4; + for ( i = 0; i < len4; i++ ) + { + y[4*i] += alpha*x[4*i]; + y[4*i+1] += alpha*x[4*i+1]; + y[4*i+2] += alpha*x[4*i+2]; + y[4*i+3] += alpha*x[4*i+3]; + } + x += 4*len4; y += 4*len4; +#endif + for ( i = 0; i < len; i++ ) + y[i] += alpha*x[i]; +} + +/* Mdot -- returns x'.y */ +double Mdot(len,x,y) +int len; +Real *x, *y; +{ + register int i, len4; + register Real sum; + +#ifndef REGISTER_RICH + sum = 0.0; +#endif + +#ifdef REGISTER_RICH + register Real sum0, sum1, sum2, sum3; + + sum0 = sum1 = sum2 = sum3 = 0.0; + + len4 = len / 4; + len = len % 4; + + for ( i = 0; i < len4; i++ ) + { + sum0 += x[4*i ]*y[4*i ]; + sum1 += x[4*i+1]*y[4*i+1]; + sum2 += x[4*i+2]*y[4*i+2]; + sum3 += x[4*i+3]*y[4*i+3]; + } + sum = sum0 + sum1 + sum2 + sum3; + x += 4*len4; y += 4*len4; +#endif + + for ( i = 0; i < len; i++ ) + sum += x[i]*y[i]; + + return sum; +} + +#ifndef ABS +#define ABS(x) ((x) >= 0 ? (x) : -(x)) +#endif + +/* Mnorminf -- returns ||x||_inf */ +double Mnorminf(len,x) +int len; +Real *x; +{ + register int i; + register Real tmp, max_val; + + max_val = 0.0; + for ( i = 0; i < len; i++ ) + { + tmp = ABS(x[i]); + if ( max_val < tmp ) + max_val = tmp; + } + + return max_val; +} + +/* Mnorm1 -- returns ||x||_1 */ +double Mnorm1(len,x) +int len; +Real *x; +{ + register int i; + register Real sum; + + sum = 0.0; + for ( i = 0; i < len; i++ ) + sum += ABS(x[i]); + + return sum; +} + +/* Mnorm2 -- returns ||x||_2 */ +double Mnorm2(len,x) +int len; +Real *x; +{ + register int i; + register Real norm, invnorm, sum, tmp; + + norm = Mnorminf(len,x); + if ( norm == 0.0 ) + return 0.0; + invnorm = 1.0/norm; + sum = 0.0; + for ( i = 0; i < len; i++ ) + { + tmp = x[i]*invnorm; + sum += tmp*tmp; + } + + return sum/invnorm; +} + +/* mblar-2 routines */ + +/* Mmv -- y <- alpha.A.x + beta.y */ +void Mmv(m,n,alpha,A,j0,x,beta,y) +int m, n, j0; +double alpha, beta; +Real **A, *x, *y; +{ + register int i, j, m4, n4; + register Real sum0, sum1, sum2, sum3, tmp0, tmp1, tmp2, tmp3; + register Real *dp0, *dp1, *dp2, *dp3; + + /**************************************** + for ( i = 0; i < m; i++ ) + y[i] += alpha*Mdot(n,&(A[i][j0]),x); + ****************************************/ + + m4 = n4 = 0; + +#ifdef REGISTER_RICH + m4 = m / 4; + m = m % 4; + n4 = n / 4; + n = n % 4; + + for ( i = 0; i < m4; i++ ) + { + sum0 = sum1 = sum2 = sum3 = 0.0; + dp0 = &(A[4*i ][j0]); + dp1 = &(A[4*i+1][j0]); + dp2 = &(A[4*i+2][j0]); + dp3 = &(A[4*i+3][j0]); + + for ( j = 0; j < n4; j++ ) + { + tmp0 = x[4*j ]; + tmp1 = x[4*j+1]; + tmp2 = x[4*j+2]; + tmp3 = x[4*j+3]; + sum0 = sum0 + dp0[j]*tmp0 + dp0[j+1]*tmp1 + + dp0[j+2]*tmp2 + dp0[j+3]*tmp3; + sum1 = sum1 + dp1[j]*tmp0 + dp1[j+1]*tmp1 + + dp1[j+2]*tmp2 + dp1[j+3]*tmp3; + sum2 = sum2 + dp2[j]*tmp0 + dp2[j+1]*tmp1 + + dp2[j+2]*tmp2 + dp2[j+3]*tmp3; + sum3 = sum3 + dp3[j]*tmp0 + dp3[j+1]*tmp2 + + dp3[j+2]*tmp2 + dp3[j+3]*tmp3; + } + for ( j = 0; j < n; j++ ) + { + sum0 += dp0[4*n4+j]*x[4*n4+j]; + sum1 += dp1[4*n4+j]*x[4*n4+j]; + sum2 += dp2[4*n4+j]*x[4*n4+j]; + sum3 += dp3[4*n4+j]*x[4*n4+j]; + } + y[4*i ] = beta*y[4*i ] + alpha*sum0; + y[4*i+1] = beta*y[4*i+1] + alpha*sum1; + y[4*i+2] = beta*y[4*i+2] + alpha*sum2; + y[4*i+3] = beta*y[4*i+3] + alpha*sum3; + } +#endif + + for ( i = 0; i < m; i++ ) + y[4*m4+i] = beta*y[i] + alpha*Mdot(4*n4+n,&(A[4*m4+i][j0]),x); +} + +/* Mvm -- y <- alpha.A^T.x + beta.y */ +void Mvm(m,n,alpha,A,j0,x,beta,y) +int m, n, j0; +double alpha, beta; +Real **A, *x, *y; +{ + register int i, j, m4, n2; + register Real *Aref; + register Real tmp; + +#ifdef REGISTER_RICH + register Real *Aref0, *Aref1; + register Real tmp0, tmp1; + register Real yval0, yval1, yval2, yval3; +#endif + + if ( beta != 1.0 ) + Mscale(m,beta,y); + /**************************************** + for ( j = 0; j < n; j++ ) + Maxpy(m,alpha*x[j],&(A[j][j0]),y); + ****************************************/ + m4 = n2 = 0; + + m4 = m / 4; + m = m % 4; +#ifdef REGISTER_RICH + n2 = n / 2; + n = n % 2; + + for ( j = 0; j < n2; j++ ) + { + tmp0 = alpha*x[2*j]; + tmp1 = alpha*x[2*j+1]; + Aref0 = &(A[2*j ][j0]); + Aref1 = &(A[2*j+1][j0]); + for ( i = 0; i < m4; i++ ) + { + yval0 = y[4*i ] + tmp0*Aref0[4*i ]; + yval1 = y[4*i+1] + tmp0*Aref0[4*i+1]; + yval2 = y[4*i+2] + tmp0*Aref0[4*i+2]; + yval3 = y[4*i+3] + tmp0*Aref0[4*i+3]; + y[4*i ] = yval0 + tmp1*Aref1[4*i ]; + y[4*i+1] = yval1 + tmp1*Aref1[4*i+1]; + y[4*i+2] = yval2 + tmp1*Aref1[4*i+2]; + y[4*i+3] = yval3 + tmp1*Aref1[4*i+3]; + } + y += 4*m4; Aref0 += 4*m4; Aref1 += 4*m4; + for ( i = 0; i < m; i++ ) + y[i] += tmp0*Aref0[i] + tmp1*Aref1[i]; + } +#endif + + for ( j = 0; j < n; j++ ) + { + tmp = alpha*x[2*n2+j]; + Aref = &(A[2*n2+j][j0]); + for ( i = 0; i < m4; i++ ) + { + y[4*i ] += tmp*Aref[4*i ]; + y[4*i+1] += tmp*Aref[4*i+1]; + y[4*i+2] += tmp*Aref[4*i+2]; + y[4*i+3] += tmp*Aref[4*i+3]; + } + y += 4*m4; Aref += 4*m4; + for ( i = 0; i < m; i++ ) + y[i] += tmp*Aref[i]; + } +} + +/* Mupdate -- A <- A + alpha.x.y^T */ +void Mupdate(m,n,alpha,x,y,A,j0) +int m, n, j0; +double alpha; +Real **A, *x, *y; +{ + register int i, j, n4; + register Real *Aref; + register Real tmp; + + /**************************************** + for ( i = 0; i < m; i++ ) + Maxpy(n,alpha*x[i],y,&(A[i][j0])); + ****************************************/ + + n4 = n / 4; + n = n % 4; + for ( i = 0; i < m; i++ ) + { + tmp = alpha*x[i]; + Aref = &(A[i][j0]); + for ( j = 0; j < n4; j++ ) + { + Aref[4*j ] += tmp*y[4*j ]; + Aref[4*j+1] += tmp*y[4*j+1]; + Aref[4*j+2] += tmp*y[4*j+2]; + Aref[4*j+3] += tmp*y[4*j+3]; + } + Aref += 4*n4; y += 4*n4; + for ( j = 0; j < n; j++ ) + Aref[j] += tmp*y[j]; + } +} + +/* mblar-3 routines */ + +/* Mmm -- C <- C + alpha.A.B */ +void Mmm(m,n,p,alpha,A,Aj0,B,Bj0,C,Cj0) +int m, n, p; /* C is m x n */ +double alpha; +Real **A, **B, **C; +int Aj0, Bj0, Cj0; +{ + register int i, j, k; + /* register Real tmp, sum; */ + + /**************************************** + for ( i = 0; i < m; i++ ) + for ( k = 0; k < p; k++ ) + Maxpy(n,alpha*A[i][Aj0+k],&(B[k][Bj0]),&(C[i][Cj0])); + ****************************************/ + for ( i = 0; i < m; i++ ) + Mvm(p,n,alpha,&(A[i][Aj0]),B,Bj0,&(C[i][Cj0])); +} + +/* Mmtrm -- C <- C + alpha.A^T.B */ +void Mmtrm(m,n,p,alpha,A,Aj0,B,Bj0,C,Cj0) +int m, n, p; /* C is m x n */ +double alpha; +Real **A, **B, **C; +int Aj0, Bj0, Cj0; +{ + register int i, j, k; + + /**************************************** + for ( i = 0; i < m; i++ ) + for ( k = 0; k < p; k++ ) + Maxpy(n,alpha*A[k][Aj0+i],&(B[k][Bj0]),&(C[i][Cj0])); + ****************************************/ + for ( k = 0; k < p; k++ ) + Mupdate(m,n,alpha,&(A[k][Aj0]),&(B[k][Bj0]),C,Cj0); +} + +/* Mmmtr -- C <- C + alpha.A.B^T */ +void Mmmtr(m,n,p,alpha,A,Aj0,B,Bj0,C,Cj0) +int m, n, p; /* C is m x n */ +double alpha; +Real **A, **B, **C; +int Aj0, Bj0, Cj0; +{ + register int i, j, k; + + /**************************************** + for ( i = 0; i < m; i++ ) + for ( j = 0; j < n; j++ ) + C[i][Cj0+j] += alpha*Mdot(p,&(A[i][Aj0]),&(B[j][Bj0])); + ****************************************/ + for ( i = 0; i < m; i++ ) + Mmv(n,p,alpha,&(A[i][Aj0]),B,Bj0,&(C[i][Cj0])); +} + +/* Mmtrmtr -- C <- C + alpha.A^T.B^T */ +void Mmtrmtr(m,n,p,alpha,A,Aj0,B,Bj0,C,Cj0) +int m, n, p; /* C is m x n */ +double alpha; +Real **A, **B, **C; +int Aj0, Bj0, Cj0; +{ + register int i, j, k; + + for ( i = 0; i < m; i++ ) + for ( j = 0; j < n; j++ ) + for ( k = 0; k < p; k++ ) + C[i][Cj0+j] += A[i][Aj0+k]*B[k][Bj0+j]; +} + diff --git a/meschach/fft.c b/meschach/fft.c new file mode 100644 index 0000000..4385037 --- /dev/null +++ b/meschach/fft.c @@ -0,0 +1,144 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Fast Fourier Transform routine + Loosely based on the Fortran routine in Rabiner & Gold's + "Digital Signal Processing" +*/ + +static char rcsid[] = "$Id: fft.c,v 1.1 2001/03/01 17:18:35 rfranke Exp $"; + +#include +#include +#include "matrix.h" +#include "matrix2.h" + + +/* fft -- d.i.t. fast Fourier transform + -- radix-2 FFT only + -- vector extended to a power of 2 */ +void fft(x_re,x_im) +VEC *x_re, *x_im; +{ + int i, ip, j, k, li, n, length; + Real *xr, *xi; + Real theta, pi = 3.1415926535897932384; + Real w_re, w_im, u_re, u_im, t_re, t_im; + Real tmp, tmpr, tmpi; + + if ( ! x_re || ! x_im ) + error(E_NULL,"fft"); + if ( x_re->dim != x_im->dim ) + error(E_SIZES,"fft"); + + n = 1; + while ( x_re->dim > n ) + n *= 2; + x_re = v_resize(x_re,n); + x_im = v_resize(x_im,n); + printf("# fft: x_re =\n"); v_output(x_re); + printf("# fft: x_im =\n"); v_output(x_im); + xr = x_re->ve; + xi = x_im->ve; + + /* Decimation in time (DIT) algorithm */ + j = 0; + for ( i = 0; i < n-1; i++ ) + { + if ( i < j ) + { + tmp = xr[i]; + xr[i] = xr[j]; + xr[j] = tmp; + tmp = xi[i]; + xi[i] = xi[j]; + xi[j] = tmp; + } + k = n / 2; + while ( k <= j ) + { + j -= k; + k /= 2; + } + j += k; + } + + /* Actual FFT */ + for ( li = 1; li < n; li *= 2 ) + { + length = 2*li; + theta = pi/li; + u_re = 1.0; + u_im = 0.0; + if ( li == 1 ) + { + w_re = -1.0; + w_im = 0.0; + } + else if ( li == 2 ) + { + w_re = 0.0; + w_im = 1.0; + } + else + { + w_re = cos(theta); + w_im = sin(theta); + } + for ( j = 0; j < li; j++ ) + { + for ( i = j; i < n; i += length ) + { + ip = i + li; + /* step 1 */ + t_re = xr[ip]*u_re - xi[ip]*u_im; + t_im = xr[ip]*u_im + xi[ip]*u_re; + /* step 2 */ + xr[ip] = xr[i] - t_re; + xi[ip] = xi[i] - t_im; + /* step 3 */ + xr[i] += t_re; + xi[i] += t_im; + } + tmpr = u_re*w_re - u_im*w_im; + tmpi = u_im*w_re + u_re*w_im; + u_re = tmpr; + u_im = tmpi; + } + } +} + +/* ifft -- inverse FFT using the same interface as fft() */ +void ifft(x_re,x_im) +VEC *x_re, *x_im; +{ + /* we just use complex conjugates */ + + sv_mlt(-1.0,x_im,x_im); + fft(x_re,x_im); + sv_mlt(-1.0/((double)(x_re->dim)),x_im,x_im); +} diff --git a/meschach/fmacheps.c b/meschach/fmacheps.c new file mode 100644 index 0000000..965cf16 --- /dev/null +++ b/meschach/fmacheps.c @@ -0,0 +1,46 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +#include + +double fclean(x) +double x; +{ + static float y; + y = x; + return y; /* prevents optimisation */ +} + +main() +{ + static float feps, feps1, ftmp; + + feps = 1.0; + while ( fclean(1.0+feps) > 1.0 ) + feps = 0.5*feps; + + printf("%g\n", 2.0*feps); +} diff --git a/meschach/givens.c b/meschach/givens.c new file mode 100644 index 0000000..c6b4734 --- /dev/null +++ b/meschach/givens.c @@ -0,0 +1,138 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + + +/* + Files for matrix computations + + Givens operations file. Contains routines for calculating and + applying givens rotations for/to vectors and also to matrices by + row and by column. +*/ + +/* givens.c 1.2 11/25/87 */ +static char rcsid[] = "$Id: givens.c,v 1.1 2001/03/01 17:18:35 rfranke Exp $"; + +#include +#include +#include "matrix.h" +#include "matrix2.h" + +/* givens -- returns c,s parameters for Givens rotation to + eliminate y in the vector [ x y ]' */ +void givens(x,y,c,s) +double x,y; +Real *c,*s; +{ + Real norm; + + norm = sqrt(x*x+y*y); + if ( norm == 0.0 ) + { *c = 1.0; *s = 0.0; } /* identity */ + else + { *c = x/norm; *s = y/norm; } +} + +/* rot_vec -- apply Givens rotation to x's i & k components */ +VEC *rot_vec(x,i,k,c,s,out) +VEC *x,*out; +u_int i,k; +double c,s; +{ + Real temp; + + if ( x==VNULL ) + error(E_NULL,"rot_vec"); + if ( i >= x->dim || k >= x->dim ) + error(E_RANGE,"rot_vec"); + out = v_copy(x,out); + + /* temp = c*out->ve[i] + s*out->ve[k]; */ + temp = c*v_entry(out,i) + s*v_entry(out,k); + /* out->ve[k] = -s*out->ve[i] + c*out->ve[k]; */ + v_set_val(out,k,-s*v_entry(out,i)+c*v_entry(out,k)); + /* out->ve[i] = temp; */ + v_set_val(out,i,temp); + + return (out); +} + +/* rot_rows -- premultiply mat by givens rotation described by c,s */ +MAT *rot_rows(mat,i,k,c,s,out) +MAT *mat,*out; +u_int i,k; +double c,s; +{ + u_int j; + Real temp; + + if ( mat==(MAT *)NULL ) + error(E_NULL,"rot_rows"); + if ( i >= mat->m || k >= mat->m ) + error(E_RANGE,"rot_rows"); + out = m_copy(mat,out); + + for ( j=0; jn; j++ ) + { + /* temp = c*out->me[i][j] + s*out->me[k][j]; */ + temp = c*m_entry(out,i,j) + s*m_entry(out,k,j); + /* out->me[k][j] = -s*out->me[i][j] + c*out->me[k][j]; */ + m_set_val(out,k,j, -s*m_entry(out,i,j) + c*m_entry(out,k,j)); + /* out->me[i][j] = temp; */ + m_set_val(out,i,j, temp); + } + + return (out); +} + +/* rot_cols -- postmultiply mat by givens rotation described by c,s */ +MAT *rot_cols(mat,i,k,c,s,out) +MAT *mat,*out; +u_int i,k; +double c,s; +{ + u_int j; + Real temp; + + if ( mat==(MAT *)NULL ) + error(E_NULL,"rot_cols"); + if ( i >= mat->n || k >= mat->n ) + error(E_RANGE,"rot_cols"); + out = m_copy(mat,out); + + for ( j=0; jm; j++ ) + { + /* temp = c*out->me[j][i] + s*out->me[j][k]; */ + temp = c*m_entry(out,j,i) + s*m_entry(out,j,k); + /* out->me[j][k] = -s*out->me[j][i] + c*out->me[j][k]; */ + m_set_val(out,j,k, -s*m_entry(out,j,i) + c*m_entry(out,j,k)); + /* out->me[j][i] = temp; */ + m_set_val(out,j,i,temp); + } + + return (out); +} + diff --git a/meschach/hessen.c b/meschach/hessen.c new file mode 100644 index 0000000..53e5418 --- /dev/null +++ b/meschach/hessen.c @@ -0,0 +1,161 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + + +/* + File containing routines for determining Hessenberg + factorisations. +*/ + +static char rcsid[] = "$Id: hessen.c,v 1.1 2001/03/01 17:18:35 rfranke Exp $"; + +#include +#include "matrix.h" +#include "matrix2.h" + + + +/* Hfactor -- compute Hessenberg factorisation in compact form. + -- factorisation performed in situ + -- for details of the compact form see QRfactor.c and matrix2.doc */ +MAT *Hfactor(A, diag, beta) +MAT *A; +VEC *diag, *beta; +{ + static VEC *tmp1 = VNULL; + int k, limit; + + if ( ! A || ! diag || ! beta ) + error(E_NULL,"Hfactor"); + if ( diag->dim < A->m - 1 || beta->dim < A->m - 1 ) + error(E_SIZES,"Hfactor"); + if ( A->m != A->n ) + error(E_SQUARE,"Hfactor"); + limit = A->m - 1; + + tmp1 = v_resize(tmp1,A->m); + MEM_STAT_REG(tmp1,TYPE_VEC); + + for ( k = 0; k < limit; k++ ) + { + get_col(A,(u_int)k,tmp1); + /* printf("the %d'th column = "); v_output(tmp1); */ + hhvec(tmp1,k+1,&beta->ve[k],tmp1,&A->me[k+1][k]); + /* rf, 10/27/00: check numerical overflow for beta + and do the same as hhvec does if norm(tmp1) is zero. + This error can't be treated in hhvec, as the overflow + may not happen there due to use of registers!!! + */ + if ( !(beta->ve[k] < HUGE_VAL) ) + { + beta->ve[k] = 0.0; + } + /* diag->ve[k] = tmp1->ve[k+1]; */ + v_set_val(diag,k,v_entry(tmp1,k+1)); + /* printf("H/h vector = "); v_output(tmp1); */ + /* printf("from the %d'th entry\n",k+1); */ + /* printf("beta = %g\n",beta->ve[k]); */ + + /* hhtrcols(A,k+1,k+1,tmp1,beta->ve[k]); */ + /* hhtrrows(A,0 ,k+1,tmp1,beta->ve[k]); */ + hhtrcols(A,k+1,k+1,tmp1,v_entry(beta,k)); + hhtrrows(A,0 ,k+1,tmp1,v_entry(beta,k)); + /* printf("A = "); m_output(A); */ + } + + return (A); +} + +/* makeHQ -- construct the Hessenberg orthogonalising matrix Q; + -- i.e. Hess M = Q.M.Q' */ +MAT *makeHQ(H, diag, beta, Qout) +MAT *H, *Qout; +VEC *diag, *beta; +{ + int i, j, limit; + static VEC *tmp1 = VNULL, *tmp2 = VNULL; + + if ( H==(MAT *)NULL || diag==(VEC *)NULL || beta==(VEC *)NULL ) + error(E_NULL,"makeHQ"); + limit = H->m - 1; + if ( diag->dim < limit || beta->dim < limit ) + error(E_SIZES,"makeHQ"); + if ( H->m != H->n ) + error(E_SQUARE,"makeHQ"); + Qout = m_resize(Qout,H->m,H->m); + + tmp1 = v_resize(tmp1,H->m); + tmp2 = v_resize(tmp2,H->m); + MEM_STAT_REG(tmp1,TYPE_VEC); + MEM_STAT_REG(tmp2,TYPE_VEC); + + for ( i = 0; i < H->m; i++ ) + { + /* tmp1 = i'th basis vector */ + for ( j = 0; j < H->m; j++ ) + /* tmp1->ve[j] = 0.0; */ + v_set_val(tmp1,j,0.0); + /* tmp1->ve[i] = 1.0; */ + v_set_val(tmp1,i,1.0); + + /* apply H/h transforms in reverse order */ + for ( j = limit-1; j >= 0; j-- ) + { + get_col(H,(u_int)j,tmp2); + /* tmp2->ve[j+1] = diag->ve[j]; */ + v_set_val(tmp2,j+1,v_entry(diag,j)); + hhtrvec(tmp2,beta->ve[j],j+1,tmp1,tmp1); + } + + /* insert into Qout */ + set_col(Qout,(u_int)i,tmp1); + } + + return (Qout); +} + +/* makeH -- construct actual Hessenberg matrix */ +MAT *makeH(H,Hout) +MAT *H, *Hout; +{ + int i, j, limit; + + if ( H==(MAT *)NULL ) + error(E_NULL,"makeH"); + if ( H->m != H->n ) + error(E_SQUARE,"makeH"); + Hout = m_resize(Hout,H->m,H->m); + Hout = m_copy(H,Hout); + + limit = H->m; + for ( i = 1; i < limit; i++ ) + for ( j = 0; j < i-1; j++ ) + /* Hout->me[i][j] = 0.0;*/ + m_set_val(Hout,i,j,0.0); + + return (Hout); +} + diff --git a/meschach/hsehldr.c b/meschach/hsehldr.c new file mode 100644 index 0000000..bd5b8f1 --- /dev/null +++ b/meschach/hsehldr.c @@ -0,0 +1,178 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Files for matrix computations + + Householder transformation file. Contains routines for calculating + householder transformations, applying them to vectors and matrices + by both row & column. +*/ + +/* hsehldr.c 1.3 10/8/87 */ +static char rcsid[] = "$Id: hsehldr.c,v 1.1 2001/03/01 17:18:35 rfranke Exp $"; + +#include +#include +#include "matrix.h" +#include "matrix2.h" + + +/* hhvec -- calulates Householder vector to eliminate all entries after the + i0 entry of the vector vec. It is returned as out. May be in-situ */ +VEC *hhvec(vec,i0,beta,out,newval) +VEC *vec,*out; +u_int i0; +Real *beta,*newval; +{ + Real norm; + + out = _v_copy(vec,out,i0); + norm = sqrt(_in_prod(out,out,i0)); + if ( norm <= 0.0 ) + { + *beta = 0.0; + return (out); + } + *beta = 1.0/(norm * (norm+fabs(out->ve[i0]))); + if ( out->ve[i0] > 0.0 ) + *newval = -norm; + else + *newval = norm; + out->ve[i0] -= *newval; + + return (out); +} + +/* hhtrvec -- apply Householder transformation to vector -- may be in-situ */ +VEC *hhtrvec(hh,beta,i0,in,out) +VEC *hh,*in,*out; /* hh = Householder vector */ +u_int i0; +double beta; +{ + Real scale; + /* u_int i; */ + + if ( hh==(VEC *)NULL || in==(VEC *)NULL ) + error(E_NULL,"hhtrvec"); + if ( in->dim != hh->dim ) + error(E_SIZES,"hhtrvec"); + if ( i0 > in->dim ) + error(E_BOUNDS,"hhtrvec"); + + scale = beta*_in_prod(hh,in,i0); + out = v_copy(in,out); + __mltadd__(&(out->ve[i0]),&(hh->ve[i0]),-scale,(int)(in->dim-i0)); + /************************************************************ + for ( i=i0; idim; i++ ) + out->ve[i] = in->ve[i] - scale*hh->ve[i]; + ************************************************************/ + + return (out); +} + +/* hhtrrows -- transform a matrix by a Householder vector by rows + starting at row i0 from column j0 -- in-situ */ +MAT *hhtrrows(M,i0,j0,hh,beta) +MAT *M; +u_int i0, j0; +VEC *hh; +double beta; +{ + Real ip, scale; + int i /*, j */; + + if ( M==(MAT *)NULL || hh==(VEC *)NULL ) + error(E_NULL,"hhtrrows"); + if ( M->n != hh->dim ) + error(E_RANGE,"hhtrrows"); + if ( i0 > M->m || j0 > M->n ) + error(E_BOUNDS,"hhtrrows"); + + if ( beta == 0.0 ) return (M); + + /* for each row ... */ + for ( i = i0; i < M->m; i++ ) + { /* compute inner product */ + ip = __ip__(&(M->me[i][j0]),&(hh->ve[j0]),(int)(M->n-j0)); + /************************************************** + ip = 0.0; + for ( j = j0; j < M->n; j++ ) + ip += M->me[i][j]*hh->ve[j]; + **************************************************/ + scale = beta*ip; + if ( scale == 0.0 ) + continue; + + /* do operation */ + __mltadd__(&(M->me[i][j0]),&(hh->ve[j0]),-scale, + (int)(M->n-j0)); + /************************************************** + for ( j = j0; j < M->n; j++ ) + M->me[i][j] -= scale*hh->ve[j]; + **************************************************/ + } + + return (M); +} + + +/* hhtrcols -- transform a matrix by a Householder vector by columns + starting at row i0 from column j0 -- in-situ */ +MAT *hhtrcols(M,i0,j0,hh,beta) +MAT *M; +u_int i0, j0; +VEC *hh; +double beta; +{ + /* Real ip, scale; */ + int i /*, k */; + static VEC *w = VNULL; + + if ( M==(MAT *)NULL || hh==(VEC *)NULL ) + error(E_NULL,"hhtrcols"); + if ( M->m != hh->dim ) + error(E_SIZES,"hhtrcols"); + if ( i0 > M->m || j0 > M->n ) + error(E_BOUNDS,"hhtrcols"); + + if ( beta == 0.0 ) return (M); + + w = v_resize(w,M->n); + MEM_STAT_REG(w,TYPE_VEC); + v_zero(w); + + for ( i = i0; i < M->m; i++ ) + if ( hh->ve[i] != 0.0 ) + __mltadd__(&(w->ve[j0]),&(M->me[i][j0]),hh->ve[i], + (int)(M->n-j0)); + for ( i = i0; i < M->m; i++ ) + if ( hh->ve[i] != 0.0 ) + __mltadd__(&(M->me[i][j0]),&(w->ve[j0]),-beta*hh->ve[i], + (int)(M->n-j0)); + return (M); +} + diff --git a/meschach/init.c b/meschach/init.c new file mode 100644 index 0000000..bdabb38 --- /dev/null +++ b/meschach/init.c @@ -0,0 +1,298 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + This is a file of routines for zero-ing, and initialising + vectors, matrices and permutations. + This is to be included in the matrix.a library +*/ + +static char rcsid[] = "$Id: init.c,v 1.1 2001/03/01 17:18:36 rfranke Exp $"; + +#include +#include "matrix.h" + +/* v_zero -- zero the vector x */ +VEC *v_zero(x) +VEC *x; +{ + if ( x == VNULL ) + error(E_NULL,"v_zero"); + + __zero__(x->ve,x->dim); + /* for ( i = 0; i < x->dim; i++ ) + x->ve[i] = 0.0; */ + + return x; +} + + +/* iv_zero -- zero the vector ix */ +IVEC *iv_zero(ix) +IVEC *ix; +{ + int i; + + if ( ix == IVNULL ) + error(E_NULL,"iv_zero"); + + for ( i = 0; i < ix->dim; i++ ) + ix->ive[i] = 0; + + return ix; +} + + +/* m_zero -- zero the matrix A */ +MAT *m_zero(A) +MAT *A; +{ + int i, A_m, A_n; + Real **A_me; + + if ( A == MNULL ) + error(E_NULL,"m_zero"); + + A_m = A->m; A_n = A->n; A_me = A->me; + for ( i = 0; i < A_m; i++ ) + __zero__(A_me[i],A_n); + /* for ( j = 0; j < A_n; j++ ) + A_me[i][j] = 0.0; */ + + return A; +} + +/* mat_id -- set A to being closest to identity matrix as possible + -- i.e. A[i][j] == 1 if i == j and 0 otherwise */ +MAT *m_ident(A) +MAT *A; +{ + int i, size; + + if ( A == MNULL ) + error(E_NULL,"m_ident"); + + m_zero(A); + size = min(A->m,A->n); + for ( i = 0; i < size; i++ ) + A->me[i][i] = 1.0; + + return A; +} + +/* px_ident -- set px to identity permutation */ +PERM *px_ident(px) +PERM *px; +{ + int i, px_size; + u_int *px_pe; + + if ( px == PNULL ) + error(E_NULL,"px_ident"); + + px_size = px->size; px_pe = px->pe; + for ( i = 0; i < px_size; i++ ) + px_pe[i] = i; + + return px; +} + +/* Pseudo random number generator data structures */ +/* Knuth's lagged Fibonacci-based generator: See "Seminumerical Algorithms: + The Art of Computer Programming" sections 3.2-3.3 */ + +#ifdef ANSI_C +#ifndef LONG_MAX +#include +#endif +#endif + +#ifdef LONG_MAX +#define MODULUS LONG_MAX +#else +#define MODULUS 1000000000L /* assuming long's at least 32 bits long */ +#endif +#define MZ 0L + +static long mrand_list[56]; +static int started = FALSE; +static int inext = 0, inextp = 31; + + +/* mrand -- pseudo-random number generator */ +#ifdef ANSI_C +double mrand(void) +#else +double mrand() +#endif +{ + long lval; + static Real factor = 1.0/((Real)MODULUS); + + if ( ! started ) + smrand(3127); + + inext = (inext >= 54) ? 0 : inext+1; + inextp = (inextp >= 54) ? 0 : inextp+1; + + lval = mrand_list[inext]-mrand_list[inextp]; + if ( lval < 0L ) + lval += MODULUS; + mrand_list[inext] = lval; + + return (double)lval*factor; +} + +/* mrandlist -- fills the array a[] with len random numbers */ +void mrandlist(a, len) +Real a[]; +int len; +{ + int i; + long lval; + static Real factor = 1.0/((Real)MODULUS); + + if ( ! started ) + smrand(3127); + + for ( i = 0; i < len; i++ ) + { + inext = (inext >= 54) ? 0 : inext+1; + inextp = (inextp >= 54) ? 0 : inextp+1; + + lval = mrand_list[inext]-mrand_list[inextp]; + if ( lval < 0L ) + lval += MODULUS; + mrand_list[inext] = lval; + + a[i] = (Real)lval*factor; + } +} + + +/* smrand -- set seed for mrand() */ +void smrand(seed) +int seed; +{ + int i; + + mrand_list[0] = (123413*seed) % MODULUS; + for ( i = 1; i < 55; i++ ) + mrand_list[i] = (123413*mrand_list[i-1]) % MODULUS; + + started = TRUE; + + /* run mrand() through the list sufficient times to + thoroughly randomise the array */ + for ( i = 0; i < 55*55; i++ ) + mrand(); +} +#undef MODULUS +#undef MZ +#undef FAC + +/* v_rand -- initialises x to be a random vector, components + independently & uniformly ditributed between 0 and 1 */ +VEC *v_rand(x) +VEC *x; +{ + /* int i; */ + + if ( ! x ) + error(E_NULL,"v_rand"); + + /* for ( i = 0; i < x->dim; i++ ) */ + /* x->ve[i] = rand()/((Real)MAX_RAND); */ + /* x->ve[i] = mrand(); */ + mrandlist(x->ve,x->dim); + + return x; +} + +/* m_rand -- initialises A to be a random vector, components + independently & uniformly distributed between 0 and 1 */ +MAT *m_rand(A) +MAT *A; +{ + int i /* , j */; + + if ( ! A ) + error(E_NULL,"m_rand"); + + for ( i = 0; i < A->m; i++ ) + /* for ( j = 0; j < A->n; j++ ) */ + /* A->me[i][j] = rand()/((Real)MAX_RAND); */ + /* A->me[i][j] = mrand(); */ + mrandlist(A->me[i],A->n); + + return A; +} + +/* v_ones -- fills x with one's */ +VEC *v_ones(x) +VEC *x; +{ + int i; + + if ( ! x ) + error(E_NULL,"v_ones"); + + for ( i = 0; i < x->dim; i++ ) + x->ve[i] = 1.0; + + return x; +} + +/* m_ones -- fills matrix with one's */ +MAT *m_ones(A) +MAT *A; +{ + int i, j; + + if ( ! A ) + error(E_NULL,"m_ones"); + + for ( i = 0; i < A->m; i++ ) + for ( j = 0; j < A->n; j++ ) + A->me[i][j] = 1.0; + + return A; +} + +/* v_count -- initialises x so that x->ve[i] == i */ +VEC *v_count(x) +VEC *x; +{ + int i; + + if ( ! x ) + error(E_NULL,"v_count"); + + for ( i = 0; i < x->dim; i++ ) + x->ve[i] = (Real)i; + + return x; +} diff --git a/meschach/iotort.c b/meschach/iotort.c new file mode 100644 index 0000000..2930fa6 --- /dev/null +++ b/meschach/iotort.c @@ -0,0 +1,141 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + +/* iotort.c 10/11/93 */ +/* test of I/O functions */ + + +static char rcsid[] = "$Id: iotort.c,v 1.1 2001/03/01 17:18:36 rfranke Exp $"; + +#include "sparse.h" +#include "zmatrix.h" + + +#define errmesg(mesg) printf("Error: %s error: line %d\n",mesg,__LINE__) +#define notice(mesg) printf("# Testing %s...\n",mesg); + + +void main() +{ + VEC *x; + MAT *A; + PERM *pivot; + IVEC *ix; + SPMAT *spA; + ZVEC *zx; + ZMAT *ZA; + char yes; + int i; + FILE *fp; + + mem_info_on(TRUE); + + if ((fp = fopen("iotort.dat","w")) == NULL) { + printf(" !!! Cannot open file %s for writing\n\n","iotort.dat"); + exit(1); + } + + x = v_get(10); + A = m_get(3,3); + zx = zv_get(10); + ZA = zm_get(3,3); + pivot = px_get(10); + ix = iv_get(10); + spA = sp_get(3,3,2); + + v_rand(x); + m_rand(A); + zv_rand(zx); + zm_rand(ZA); + px_ident(pivot); + for (i=0; i < 10; i++) + ix->ive[i] = i+1; + for (i=0; i < spA->m; i++) { + sp_set_val(spA,i,i,1.0); + if (i > 0) sp_set_val(spA,i-1,i,-1.0); + } + + notice(" VEC output"); + v_foutput(fp,x); + notice(" MAT output"); + m_foutput(fp,A); + notice(" ZVEC output"); + zv_foutput(fp,zx); + notice(" ZMAT output"); + zm_foutput(fp,ZA); + notice(" PERM output"); + px_foutput(fp,pivot); + notice(" IVEC output"); + iv_foutput(fp,ix); + notice(" SPMAT output"); + sp_foutput(fp,spA); + fprintf(fp,"Y"); + fclose(fp); + + printf("\nENTER SOME VALUES:\n\n"); + + if ((fp = fopen("iotort.dat","r")) == NULL) { + printf(" !!! Cannot open file %s for reading\n\n","iotort.dat"); + exit(1); + } + + notice(" VEC input/output"); + x = v_finput(fp,x); + v_output(x); + + notice(" MAT input/output"); + A = m_finput(fp,A); + m_output(A); + + notice(" ZVEC input/output"); + zx = zv_finput(fp,zx); + zv_output(zx); + + notice(" ZMAT input/output"); + ZA = zm_finput(fp,ZA); + zm_output(ZA); + + notice(" PERM input/output"); + pivot = px_finput(fp,pivot); + px_output(pivot); + + notice(" IVEC input/output"); + ix = iv_finput(fp,ix); + iv_output(ix); + + notice(" SPMAT input/output"); + SP_FREE(spA); + spA = sp_finput(fp); + sp_output(spA); + + notice(" general input"); + finput(fp," finish the test? ","%c",&yes); + if (yes == 'y' || yes == 'Y' ) + printf(" YES\n"); + else printf(" NO\n"); + fclose(fp); + + mem_info(); +} diff --git a/meschach/iter.h b/meschach/iter.h new file mode 100644 index 0000000..bed3d92 --- /dev/null +++ b/meschach/iter.h @@ -0,0 +1,248 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* iter.h 14/09/93 */ + +/* + + Structures for iterative methods + +*/ + +#ifndef ITERHH + +#define ITERHH + +/* RCS id: $Id: iter.h,v 1.1 2001/03/01 17:18:37 rfranke Exp $ */ + + +#include "sparse.h" + + +/* basic structure for iterative methods */ + +/* type Fun_Ax for functions to get y = A*x */ +#ifdef ANSI_C +typedef VEC *(*Fun_Ax)(void *,VEC *,VEC *); +#else +typedef VEC *(*Fun_Ax)(); +#endif + + +/* type ITER */ +typedef struct Iter_data { + int shared_x; /* if TRUE then x is shared and it will not be free'd */ + int shared_b; /* if TRUE then b is shared and it will not be free'd */ + unsigned k; /* no. of direction (search) vectors; =0 - none */ + int limit; /* upper bound on the no. of iter. steps */ + int steps; /* no. of iter. steps done */ + Real eps; /* accuracy required */ + + VEC *x; /* input: initial guess; + output: approximate solution */ + VEC *b; /* right hand side of the equation A*x = b */ + + Fun_Ax Ax; /* function computing y = A*x */ + void *A_par; /* parameters for Ax */ + + Fun_Ax ATx; /* function computing y = A^T*x; + T = transpose */ + void *AT_par; /* parameters for ATx */ + + Fun_Ax Bx; /* function computing y = B*x; B - preconditioner */ + void *B_par; /* parameters for Bx */ + +#ifdef ANSI_C + +#ifdef PROTOTYPES_IN_STRUCT + void (*info)(struct Iter_data *, double, VEC *,VEC *); + /* function giving some information for a user; + nres - a norm of a residual res */ + + int (*stop_crit)(struct Iter_data *, double, VEC *,VEC *); + /* stopping criterion: + nres - a norm of res; + res - residual; + if returned value == TRUE then stop; + if returned value == FALSE then continue; */ +#else + void (*info)(); + int (*stop_crit)(); +#endif /* PROTOTYPES_IN_STRUCT */ + +#else + + void (*info)(); + /* function giving some information for a user */ + + int (*stop_crit)(); + /* stopping criterion: + if returned value == TRUE then stop; + if returned value == FALSE then continue; */ + +#endif /* ANSI_C */ + + Real init_res; /* the norm of the initial residual */ + +} ITER; + + +#define INULL (ITER *)NULL + +/* type Fun_info */ +#ifdef ANSI_C +typedef void (*Fun_info)(ITER *, double, VEC *,VEC *); +#else +typedef void (*Fun_info)(); +#endif + +/* type Fun_stp_crt */ +#ifdef ANSI_C +typedef int (*Fun_stp_crt)(ITER *, double, VEC *,VEC *); +#else +typedef int (*Fun_stp_crt)(); +#endif + + + +/* macros */ +/* default values */ + +#define ITER_LIMIT_DEF 1000 +#define ITER_EPS_DEF 1e-6 + +/* other macros */ + +/* set ip->Ax=fun and ip->A_par=fun_par */ +#define iter_Ax(ip,fun,fun_par) \ + (ip->Ax=(Fun_Ax)(fun),ip->A_par=(void *)(fun_par),0) +#define iter_ATx(ip,fun,fun_par) \ + (ip->ATx=(Fun_Ax)(fun),ip->AT_par=(void *)(fun_par),0) +#define iter_Bx(ip,fun,fun_par) \ + (ip->Bx=(Fun_Ax)(fun),ip->B_par=(void *)(fun_par),0) + +/* save free macro */ +#define ITER_FREE(ip) (iter_free(ip), (ip)=(ITER *)NULL) + + +/* prototypes from iter0.c */ + +#ifdef ANSI_C +/* standard information */ +void iter_std_info(ITER *ip,double nres,VEC *res,VEC *Bres); +/* standard stopping criterion */ +int iter_std_stop_crit(ITER *ip, double nres, VEC *res,VEC *Bres); + +/* get, resize and free ITER variable */ +ITER *iter_get(int lenb, int lenx); +ITER *iter_resize(ITER *ip,int lenb,int lenx); +int iter_free(ITER *ip); + +void iter_dump(FILE *fp,ITER *ip); + +/* copy ip1 to ip2 copying also elements of x and b */ +ITER *iter_copy(ITER *ip1, ITER *ip2); +/* copy ip1 to ip2 without copying elements of x and b */ +ITER *iter_copy2(ITER *ip1,ITER *ip2); + +/* functions for generating sparse matrices with random elements */ +SPMAT *iter_gen_sym(int n, int nrow); +SPMAT *iter_gen_nonsym(int m,int n,int nrow,double diag); +SPMAT *iter_gen_nonsym_posdef(int n,int nrow); + +#else + +void iter_std_info(); +int iter_std_stop_crit(); +ITER *iter_get(); +int iter_free(); +ITER *iter_resize(); +void iter_dump(); +ITER *iter_copy(); +ITER *iter_copy2(); +SPMAT *iter_gen_sym(); +SPMAT *iter_gen_nonsym(); +SPMAT *iter_gen_nonsym_posdef(); + +#endif + +/* prototypes from iter.c */ + +/* different iterative procedures */ +#ifdef ANSI_C +VEC *iter_cg(ITER *ip); +VEC *iter_cg1(ITER *ip); +VEC *iter_spcg(SPMAT *A,SPMAT *LLT,VEC *b,double eps,VEC *x,int limit, + int *steps); +VEC *iter_cgs(ITER *ip,VEC *r0); +VEC *iter_spcgs(SPMAT *A,SPMAT *B,VEC *b,VEC *r0,double eps,VEC *x, + int limit, int *steps); +VEC *iter_lsqr(ITER *ip); +VEC *iter_splsqr(SPMAT *A,VEC *b,double tol,VEC *x, + int limit,int *steps); +VEC *iter_gmres(ITER *ip); +VEC *iter_spgmres(SPMAT *A,SPMAT *B,VEC *b,double tol,VEC *x,int k, + int limit, int *steps); +MAT *iter_arnoldi_iref(ITER *ip,Real *h,MAT *Q,MAT *H); +MAT *iter_arnoldi(ITER *ip,Real *h,MAT *Q,MAT *H); +MAT *iter_sparnoldi(SPMAT *A,VEC *x0,int k,Real *h,MAT *Q,MAT *H); +VEC *iter_mgcr(ITER *ip); +VEC *iter_spmgcr(SPMAT *A,SPMAT *B,VEC *b,double tol,VEC *x,int k, + int limit, int *steps); +void iter_lanczos(ITER *ip,VEC *a,VEC *b,Real *beta2,MAT *Q); +void iter_splanczos(SPMAT *A,int m,VEC *x0,VEC *a,VEC *b,Real *beta2, + MAT *Q); +VEC *iter_lanczos2(ITER *ip,VEC *evals,VEC *err_est); +VEC *iter_splanczos2(SPMAT *A,int m,VEC *x0,VEC *evals,VEC *err_est); +VEC *iter_cgne(ITER *ip); +VEC *iter_spcgne(SPMAT *A,SPMAT *B,VEC *b,double eps,VEC *x, + int limit,int *steps); +#else +VEC *iter_cg(); +VEC *iter_cg1(); +VEC *iter_spcg(); +VEC *iter_cgs(); +VEC *iter_spcgs(); +VEC *iter_lsqr(); +VEC *iter_splsqr(); +VEC *iter_gmres(); +VEC *iter_spgmres(); +MAT *iter_arnoldi_iref(); +MAT *iter_arnoldi(); +MAT *iter_sparnoldi(); +VEC *iter_mgcr(); +VEC *iter_spmgcr(); +void iter_lanczos(); +void iter_splanczos(); +VEC *iter_lanczos2(); +VEC *iter_splanczos2(); +VEC *iter_cgne(); +VEC *iter_spcgne(); + +#endif + + +#endif /* ITERHH */ diff --git a/meschach/iter0.c b/meschach/iter0.c new file mode 100644 index 0000000..b41de1a --- /dev/null +++ b/meschach/iter0.c @@ -0,0 +1,381 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* iter0.c 14/09/93 */ + +/* ITERATIVE METHODS - service functions */ + +/* functions for creating and releasing ITER structures; + for memory information; + for getting some values from an ITER variable; + for changing values in an ITER variable; + see also iter.c +*/ + +#include +#include +#include "iter.h" + + +static char rcsid[] = "$Id: iter0.c,v 1.1 2001/03/01 17:18:37 rfranke Exp $"; + + +/* standard functions */ + +/* standard information */ +void iter_std_info(ip,nres,res,Bres) +ITER *ip; +double nres; +VEC *res, *Bres; +{ + if (nres >= 0.0) + printf(" %d. residual = %g\n",ip->steps,nres); + else + printf(" %d. residual = %g (WARNING !!! should be >= 0) \n", + ip->steps,nres); +} + +/* standard stopping criterion */ +int iter_std_stop_crit(ip, nres, res, Bres) +ITER *ip; +double nres; +VEC *res, *Bres; +{ + /* save initial value of the residual in init_res */ + if (ip->steps == 0) + ip->init_res = fabs(nres); + + /* standard stopping criterium */ + if (nres <= ip->init_res*ip->eps) return TRUE; + return FALSE; +} + + +/* iter_get - create a new structure pointing to ITER */ + +ITER *iter_get(lenb, lenx) +int lenb, lenx; +{ + ITER *ip; + + if ((ip = NEW(ITER)) == (ITER *) NULL) + error(E_MEM,"iter_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_ITER,0,sizeof(ITER)); + mem_numvar(TYPE_ITER,1); + } + + /* default values */ + + ip->shared_x = FALSE; + ip->shared_b = FALSE; + ip->k = 0; + ip->limit = ITER_LIMIT_DEF; + ip->eps = ITER_EPS_DEF; + ip->steps = 0; + + if (lenb > 0) ip->b = v_get(lenb); + else ip->b = (VEC *)NULL; + + if (lenx > 0) ip->x = v_get(lenx); + else ip->x = (VEC *)NULL; + + ip->Ax = ip->A_par = NULL; + ip->ATx = ip->AT_par = NULL; + ip->Bx = ip->B_par = NULL; + ip->info = iter_std_info; + ip->stop_crit = iter_std_stop_crit; + ip->init_res = 0.0; + + return ip; +} + + +/* iter_free - release memory */ +int iter_free(ip) +ITER *ip; +{ + if (ip == (ITER *)NULL) return -1; + + if (mem_info_is_on()) { + mem_bytes(TYPE_ITER,sizeof(ITER),0); + mem_numvar(TYPE_ITER,-1); + } + + if ( !ip->shared_x && ip->x != NULL ) v_free(ip->x); + if ( !ip->shared_b && ip->b != NULL ) v_free(ip->b); + + free((char *)ip); + + return 0; +} + +ITER *iter_resize(ip,new_lenb,new_lenx) +ITER *ip; +int new_lenb, new_lenx; +{ + VEC *old; + + if ( ip == (ITER *) NULL) + error(E_NULL,"iter_resize"); + + old = ip->x; + ip->x = v_resize(ip->x,new_lenx); + if ( ip->shared_x && old != ip->x ) + warning(WARN_SHARED_VEC,"iter_resize"); + old = ip->b; + ip->b = v_resize(ip->b,new_lenb); + if ( ip->shared_b && old != ip->b ) + warning(WARN_SHARED_VEC,"iter_resize"); + + return ip; +} + + +/* print out ip structure - for diagnostic purposes mainly */ +void iter_dump(fp,ip) +ITER *ip; +FILE *fp; +{ + if (ip == NULL) { + fprintf(fp," ITER structure: NULL\n"); + return; + } + + fprintf(fp,"\n ITER structure:\n"); + fprintf(fp," ip->shared_x = %s, ip->shared_b = %s\n", + (ip->shared_x ? "TRUE" : "FALSE"), + (ip->shared_b ? "TRUE" : "FALSE") ); + fprintf(fp," ip->k = %d, ip->limit = %d, ip->steps = %d, ip->eps = %g\n", + ip->k,ip->limit,ip->steps,ip->eps); + fprintf(fp," ip->x = 0x%p, ip->b = 0x%p\n",ip->x,ip->b); + fprintf(fp," ip->Ax = 0x%p, ip->A_par = 0x%p\n",ip->Ax,ip->A_par); + fprintf(fp," ip->ATx = 0x%p, ip->AT_par = 0x%p\n",ip->ATx,ip->AT_par); + fprintf(fp," ip->Bx = 0x%p, ip->B_par = 0x%p\n",ip->Bx,ip->B_par); + fprintf(fp," ip->info = 0x%p, ip->stop_crit = 0x%p, ip->init_res = %g\n", + ip->info,ip->stop_crit,ip->init_res); + fprintf(fp,"\n"); + +} + + +/* copy the structure ip1 to ip2 preserving vectors x and b of ip2 + (vectors x and b in ip2 are the same before and after iter_copy2) + if ip2 == NULL then a new structure is created with x and b being NULL + and other members are taken from ip1 +*/ +ITER *iter_copy2(ip1,ip2) +ITER *ip1, *ip2; +{ + VEC *x, *b; + int shx, shb; + + if (ip1 == (ITER *)NULL) + error(E_NULL,"iter_copy2"); + + if (ip2 == (ITER *)NULL) { + if ((ip2 = NEW(ITER)) == (ITER *) NULL) + error(E_MEM,"iter_copy2"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_ITER,0,sizeof(ITER)); + mem_numvar(TYPE_ITER,1); + } + ip2->x = ip2->b = NULL; + ip2->shared_x = ip2->shared_x = FALSE; + } + + x = ip2->x; + b = ip2->b; + shb = ip2->shared_b; + shx = ip2->shared_x; + MEM_COPY(ip1,ip2,sizeof(ITER)); + ip2->x = x; + ip2->b = b; + ip2->shared_x = shx; + ip2->shared_b = shb; + + return ip2; +} + + +/* copy the structure ip1 to ip2 copying also the vectors x and b */ +ITER *iter_copy(ip1,ip2) +ITER *ip1, *ip2; +{ + VEC *x, *b; + + if (ip1 == (ITER *)NULL) + error(E_NULL,"iter_copy"); + + if (ip2 == (ITER *)NULL) { + if ((ip2 = NEW(ITER)) == (ITER *) NULL) + error(E_MEM,"iter_copy2"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_ITER,0,sizeof(ITER)); + mem_numvar(TYPE_ITER,1); + } + } + + x = ip2->x; + b = ip2->b; + + MEM_COPY(ip1,ip2,sizeof(ITER)); + if (ip1->x) + ip2->x = v_copy(ip1->x,x); + if (ip1->b) + ip2->b = v_copy(ip1->b,b); + + ip2->shared_x = ip2->shared_b = FALSE; + + return ip2; +} + + +/*** functions to generate sparse matrices with random entries ***/ + + +/* iter_gen_sym -- generate symmetric positive definite + n x n matrix, + nrow - number of nonzero entries in a row + */ +SPMAT *iter_gen_sym(n,nrow) +int n, nrow; +{ + SPMAT *A; + VEC *u; + Real s1; + int i, j, k, k_max; + + if (nrow <= 1) nrow = 2; + /* nrow should be even */ + if ((nrow & 1)) nrow -= 1; + A = sp_get(n,n,nrow); + u = v_get(A->m); + v_zero(u); + for ( i = 0; i < A->m; i++ ) + { + k_max = ((rand() >> 8) % (nrow/2)); + for ( k = 0; k <= k_max; k++ ) + { + j = (rand() >> 8) % A->n; + s1 = mrand(); + sp_set_val(A,i,j,s1); + sp_set_val(A,j,i,s1); + u->ve[i] += fabs(s1); + u->ve[j] += fabs(s1); + } + } + /* ensure that A is positive definite */ + for ( i = 0; i < A->m; i++ ) + sp_set_val(A,i,i,u->ve[i] + 1.0); + + V_FREE(u); + return A; +} + + +/* iter_gen_nonsym -- generate non-symmetric m x n sparse matrix, m >= n + nrow - number of entries in a row; + diag - number which is put in diagonal entries and then permuted + (if diag is zero then 1.0 is there) +*/ +SPMAT *iter_gen_nonsym(m,n,nrow,diag) +int m, n, nrow; +double diag; +{ + SPMAT *A; + PERM *px; + int i, j, k, k_max; + Real s1; + + if (nrow <= 1) nrow = 2; + if (diag == 0.0) diag = 1.0; + A = sp_get(m,n,nrow); + px = px_get(n); + for ( i = 0; i < A->m; i++ ) + { + k_max = (rand() >> 8) % (nrow-1); + for ( k = 0; k <= k_max; k++ ) + { + j = (rand() >> 8) % A->n; + s1 = mrand(); + sp_set_val(A,i,j,-s1); + } + } + /* to make it likely that A is nonsingular, use pivot... */ + for ( i = 0; i < 2*A->n; i++ ) + { + j = (rand() >> 8) % A->n; + k = (rand() >> 8) % A->n; + px_transp(px,j,k); + } + for ( i = 0; i < A->n; i++ ) + sp_set_val(A,i,px->pe[i],diag); + + PX_FREE(px); + return A; +} + + +/* iter_gen_nonsym -- generate non-symmetric positive definite + n x n sparse matrix; + nrow - number of entries in a row +*/ +SPMAT *iter_gen_nonsym_posdef(n,nrow) +int n, nrow; +{ + SPMAT *A; + PERM *px; + VEC *u; + int i, j, k, k_max; + Real s1; + + if (nrow <= 1) nrow = 2; + A = sp_get(n,n,nrow); + px = px_get(n); + u = v_get(A->m); + v_zero(u); + for ( i = 0; i < A->m; i++ ) + { + k_max = (rand() >> 8) % (nrow-1); + for ( k = 0; k <= k_max; k++ ) + { + j = (rand() >> 8) % A->n; + s1 = mrand(); + sp_set_val(A,i,j,-s1); + u->ve[i] += fabs(s1); + } + } + /* ensure that A is positive definite */ + for ( i = 0; i < A->m; i++ ) + sp_set_val(A,i,i,u->ve[i] + 1.0); + + PX_FREE(px); + V_FREE(u); + return A; +} + + diff --git a/meschach/iternsym.c b/meschach/iternsym.c new file mode 100644 index 0000000..6a5a160 --- /dev/null +++ b/meschach/iternsym.c @@ -0,0 +1,1255 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* iter.c 17/09/93 */ + +/* + ITERATIVE METHODS - implementation of several iterative methods; + see also iter0.c +*/ + +#include +#include +#include "matrix.h" +#include "matrix2.h" +#include "sparse.h" +#include "iter.h" + +static char rcsid[] = "$Id: iternsym.c,v 1.1 2001/03/01 17:18:39 rfranke Exp $"; + + +#ifdef ANSI_C +VEC *spCHsolve(SPMAT *,VEC *,VEC *); +#else +VEC *spCHsolve(); +#endif + + +/* + iter_cgs -- uses CGS to compute a solution x to A.x=b +*/ + +VEC *iter_cgs(ip,r0) +ITER *ip; +VEC *r0; +{ + static VEC *p = VNULL, *q = VNULL, *r = VNULL, *u = VNULL; + static VEC *v = VNULL, *z = VNULL; + VEC *tmp; + Real alpha, beta, nres, rho, old_rho, sigma, inner; + + if (ip == INULL) + error(E_NULL,"iter_cgs"); + if (!ip->Ax || !ip->b || !r0) + error(E_NULL,"iter_cgs"); + if ( ip->x == ip->b ) + error(E_INSITU,"iter_cgs"); + if (!ip->stop_crit) + error(E_NULL,"iter_cgs"); + if ( r0->dim != ip->b->dim ) + error(E_SIZES,"iter_cgs"); + + if ( ip->eps <= 0.0 ) + ip->eps = MACHEPS; + + p = v_resize(p,ip->b->dim); + q = v_resize(q,ip->b->dim); + r = v_resize(r,ip->b->dim); + u = v_resize(u,ip->b->dim); + v = v_resize(v,ip->b->dim); + + MEM_STAT_REG(p,TYPE_VEC); + MEM_STAT_REG(q,TYPE_VEC); + MEM_STAT_REG(r,TYPE_VEC); + MEM_STAT_REG(u,TYPE_VEC); + MEM_STAT_REG(v,TYPE_VEC); + + if (ip->Bx) { + z = v_resize(z,ip->b->dim); + MEM_STAT_REG(z,TYPE_VEC); + } + + if (ip->x != VNULL) { + if (ip->x->dim != ip->b->dim) + error(E_SIZES,"iter_cgs"); + ip->Ax(ip->A_par,ip->x,v); /* v = A*x */ + if (ip->Bx) { + v_sub(ip->b,v,v); /* v = b - A*x */ + (ip->Bx)(ip->B_par,v,r); /* r = B*(b-A*x) */ + } + else v_sub(ip->b,v,r); /* r = b-A*x */ + } + else { /* ip->x == 0 */ + ip->x = v_get(ip->b->dim); /* x == 0 */ + ip->shared_x = FALSE; + if (ip->Bx) (ip->Bx)(ip->B_par,ip->b,r); /* r = B*b */ + else v_copy(ip->b,r); /* r = b */ + } + + v_zero(p); + v_zero(q); + old_rho = 1.0; + + for (ip->steps = 0; ip->steps <= ip->limit; ip->steps++) { + + inner = in_prod(r,r); + nres = sqrt(fabs(inner)); + + if (ip->info) ip->info(ip,nres,r,VNULL); + if ( ip->stop_crit(ip,nres,r,VNULL) ) break; + + rho = in_prod(r0,r); + if ( old_rho == 0.0 ) + error(E_SING,"iter_cgs"); + beta = rho/old_rho; + v_mltadd(r,q,beta,u); + v_mltadd(q,p,beta,v); + v_mltadd(u,v,beta,p); + + (ip->Ax)(ip->A_par,p,q); + if (ip->Bx) { + (ip->Bx)(ip->B_par,q,z); + tmp = z; + } + else tmp = q; + + sigma = in_prod(r0,tmp); + if ( sigma == 0.0 ) + error(E_SING,"iter_cgs"); + alpha = rho/sigma; + v_mltadd(u,tmp,-alpha,q); + v_add(u,q,v); + + (ip->Ax)(ip->A_par,v,u); + if (ip->Bx) { + (ip->Bx)(ip->B_par,u,z); + tmp = z; + } + else tmp = u; + + v_mltadd(r,tmp,-alpha,r); + v_mltadd(ip->x,v,alpha,ip->x); + + old_rho = rho; + } + + return ip->x; +} + + + +/* iter_spcgs -- simple interface for SPMAT data structures + use always as follows: + x = iter_spcgs(A,B,b,r0,tol,x,limit,steps); + or + x = iter_spcgs(A,B,b,r0,tol,VNULL,limit,steps); + In the second case the solution vector is created. + If B is not NULL then it is a preconditioner. +*/ +VEC *iter_spcgs(A,B,b,r0,tol,x,limit,steps) +SPMAT *A, *B; +VEC *b, *r0, *x; +double tol; +int *steps,limit; +{ + ITER *ip; + + ip = iter_get(0,0); + ip->Ax = (Fun_Ax) sp_mv_mlt; + ip->A_par = (void *) A; + if (B) { + ip->Bx = (Fun_Ax) sp_mv_mlt; + ip->B_par = (void *) B; + } + else { + ip->Bx = (Fun_Ax) NULL; + ip->B_par = NULL; + } + ip->info = (Fun_info) NULL; + ip->limit = limit; + ip->b = b; + ip->eps = tol; + ip->x = x; + iter_cgs(ip,r0); + x = ip->x; + if (steps) *steps = ip->steps; + ip->shared_x = ip->shared_b = TRUE; + iter_free(ip); /* release only ITER structure */ + return x; + +} + +/* + Routine for performing LSQR -- the least squares QR algorithm + of Paige and Saunders: + "LSQR: an algorithm for sparse linear equations and + sparse least squares", ACM Trans. Math. Soft., v. 8 + pp. 43--71 (1982) + */ +/* lsqr -- sparse CG-like least squares routine: + -- finds min_x ||A.x-b||_2 using A defined through A & AT + -- returns x (if x != NULL) */ +VEC *iter_lsqr(ip) +ITER *ip; +{ + static VEC *u = VNULL, *v = VNULL, *w = VNULL, *tmp = VNULL; + Real alpha, beta, phi, phi_bar; + Real rho, rho_bar, rho_max, theta, nres; + Real s, c; /* for Givens' rotations */ + int m, n; + + if ( ! ip || ! ip->b || !ip->Ax || !ip->ATx ) + error(E_NULL,"iter_lsqr"); + if ( ip->x == ip->b ) + error(E_INSITU,"iter_lsqr"); + if (!ip->stop_crit || !ip->x) + error(E_NULL,"iter_lsqr"); + + if ( ip->eps <= 0.0 ) + ip->eps = MACHEPS; + + m = ip->b->dim; + n = ip->x->dim; + + u = v_resize(u,(u_int)m); + v = v_resize(v,(u_int)n); + w = v_resize(w,(u_int)n); + tmp = v_resize(tmp,(u_int)n); + + MEM_STAT_REG(u,TYPE_VEC); + MEM_STAT_REG(v,TYPE_VEC); + MEM_STAT_REG(w,TYPE_VEC); + MEM_STAT_REG(tmp,TYPE_VEC); + + if (ip->x != VNULL) { + ip->Ax(ip->A_par,ip->x,u); /* u = A*x */ + v_sub(ip->b,u,u); /* u = b-A*x */ + } + else { /* ip->x == 0 */ + ip->x = v_get(ip->b->dim); + ip->shared_x = FALSE; + v_copy(ip->b,u); /* u = b */ + } + + beta = v_norm2(u); + if ( beta == 0.0 ) + return ip->x; + sv_mlt(1.0/beta,u,u); + (ip->ATx)(ip->AT_par,u,v); + alpha = v_norm2(v); + if ( alpha == 0.0 ) + return ip->x; + sv_mlt(1.0/alpha,v,v); + v_copy(v,w); + phi_bar = beta; + rho_bar = alpha; + + rho_max = 1.0; + for (ip->steps = 0; ip->steps <= ip->limit; ip->steps++) { + + tmp = v_resize(tmp,m); + (ip->Ax)(ip->A_par,v,tmp); + + v_mltadd(tmp,u,-alpha,u); + beta = v_norm2(u); + sv_mlt(1.0/beta,u,u); + + tmp = v_resize(tmp,n); + (ip->ATx)(ip->AT_par,u,tmp); + v_mltadd(tmp,v,-beta,v); + alpha = v_norm2(v); + sv_mlt(1.0/alpha,v,v); + + rho = sqrt(rho_bar*rho_bar+beta*beta); + if ( rho > rho_max ) + rho_max = rho; + c = rho_bar/rho; + s = beta/rho; + theta = s*alpha; + rho_bar = -c*alpha; + phi = c*phi_bar; + phi_bar = s*phi_bar; + + /* update ip->x & w */ + if ( rho == 0.0 ) + error(E_SING,"iter_lsqr"); + v_mltadd(ip->x,w,phi/rho,ip->x); + v_mltadd(v,w,-theta/rho,w); + + nres = fabs(phi_bar*alpha*c)*rho_max; + + if (ip->info) ip->info(ip,nres,w,VNULL); + if ( ip->stop_crit(ip,nres,w,VNULL) ) break; + } + + return ip->x; +} + +/* iter_splsqr -- simple interface for SPMAT data structures */ +VEC *iter_splsqr(A,b,tol,x,limit,steps) +SPMAT *A; +VEC *b, *x; +double tol; +int *steps,limit; +{ + ITER *ip; + + ip = iter_get(0,0); + ip->Ax = (Fun_Ax) sp_mv_mlt; + ip->A_par = (void *) A; + ip->ATx = (Fun_Ax) sp_vm_mlt; + ip->AT_par = (void *) A; + ip->Bx = (Fun_Ax) NULL; + ip->B_par = NULL; + + ip->info = (Fun_info) NULL; + ip->limit = limit; + ip->b = b; + ip->eps = tol; + ip->x = x; + iter_lsqr(ip); + x = ip->x; + if (steps) *steps = ip->steps; + ip->shared_x = ip->shared_b = TRUE; + iter_free(ip); /* release only ITER structure */ + return x; +} + + + +/* iter_arnoldi -- an implementation of the Arnoldi method; + iterative refinement is applied. +*/ +MAT *iter_arnoldi_iref(ip,h_rem,Q,H) +ITER *ip; +Real *h_rem; +MAT *Q, *H; +{ + static VEC *u=VNULL, *r=VNULL, *s=VNULL, *tmp=VNULL; + VEC v; /* auxiliary vector */ + int i,j; + Real h_val, c; + + if (ip == INULL) + error(E_NULL,"iter_arnoldi_iref"); + if ( ! ip->Ax || ! Q || ! ip->x ) + error(E_NULL,"iter_arnoldi_iref"); + if ( ip->k <= 0 ) + error(E_BOUNDS,"iter_arnoldi_iref"); + if ( Q->n != ip->x->dim || Q->m != ip->k ) + error(E_SIZES,"iter_arnoldi_iref"); + + m_zero(Q); + H = m_resize(H,ip->k,ip->k); + m_zero(H); + + u = v_resize(u,ip->x->dim); + tmp = v_resize(tmp,ip->x->dim); + r = v_resize(r,ip->k); + s = v_resize(s,ip->k); + MEM_STAT_REG(u,TYPE_VEC); + MEM_STAT_REG(tmp,TYPE_VEC); + MEM_STAT_REG(r,TYPE_VEC); + MEM_STAT_REG(s,TYPE_VEC); + + v.dim = v.max_dim = ip->x->dim; + + c = v_norm2(ip->x); + if ( c <= 0.0) + return H; + else { + v.ve = Q->me[0]; + sv_mlt(1.0/c,ip->x,&v); + } + + v_zero(r); + v_zero(s); + for ( i = 0; i < ip->k; i++ ) + { + v.ve = Q->me[i]; + u = (ip->Ax)(ip->A_par,&v,u); + v_zero(tmp); + for (j = 0; j <= i; j++) { + v.ve = Q->me[j]; + r->ve[j] = in_prod(&v,u); + v_mltadd(tmp,&v,r->ve[j],tmp); + } + v_sub(u,tmp,u); + h_val = v_norm2(u); + /* if u == 0 then we have an exact subspace */ + if ( h_val <= 0.0 ) + { + *h_rem = h_val; + return H; + } + /* iterative refinement -- ensures near orthogonality */ + do { + v_zero(tmp); + for (j = 0; j <= i; j++) { + v.ve = Q->me[j]; + s->ve[j] = in_prod(&v,u); + v_mltadd(tmp,&v,s->ve[j],tmp); + } + v_sub(u,tmp,u); + v_add(r,s,r); + } while ( v_norm2(s) > 0.1*(h_val = v_norm2(u)) ); + /* now that u is nearly orthogonal to Q, update H */ + set_col(H,i,r); + /* check once again if h_val is zero */ + if ( h_val <= 0.0 ) + { + *h_rem = h_val; + return H; + } + if ( i == ip->k-1 ) + { + *h_rem = h_val; + continue; + } + /* H->me[i+1][i] = h_val; */ + m_set_val(H,i+1,i,h_val); + v.ve = Q->me[i+1]; + sv_mlt(1.0/h_val,u,&v); + } + + return H; +} + +/* iter_arnoldi -- an implementation of the Arnoldi method; + without iterative refinement +*/ +MAT *iter_arnoldi(ip,h_rem,Q,H) +ITER *ip; +Real *h_rem; +MAT *Q, *H; +{ + static VEC *u=VNULL, *r=VNULL, *tmp=VNULL; + VEC v; /* auxiliary vector */ + int i,j; + Real h_val, c; + + if (ip == INULL) + error(E_NULL,"iter_arnoldi"); + if ( ! ip->Ax || ! Q || ! ip->x ) + error(E_NULL,"iter_arnoldi"); + if ( ip->k <= 0 ) + error(E_BOUNDS,"iter_arnoldi"); + if ( Q->n != ip->x->dim || Q->m != ip->k ) + error(E_SIZES,"iter_arnoldi"); + + m_zero(Q); + H = m_resize(H,ip->k,ip->k); + m_zero(H); + + u = v_resize(u,ip->x->dim); + tmp = v_resize(tmp,ip->x->dim); + r = v_resize(r,ip->k); + MEM_STAT_REG(u,TYPE_VEC); + MEM_STAT_REG(tmp,TYPE_VEC); + MEM_STAT_REG(r,TYPE_VEC); + + v.dim = v.max_dim = ip->x->dim; + + c = v_norm2(ip->x); + if ( c <= 0.0) + return H; + else { + v.ve = Q->me[0]; + sv_mlt(1.0/c,ip->x,&v); + } + + v_zero(r); + for ( i = 0; i < ip->k; i++ ) + { + v.ve = Q->me[i]; + u = (ip->Ax)(ip->A_par,&v,u); + v_zero(tmp); + for (j = 0; j <= i; j++) { + v.ve = Q->me[j]; + r->ve[j] = in_prod(&v,u); + v_mltadd(tmp,&v,r->ve[j],tmp); + } + v_sub(u,tmp,u); + h_val = v_norm2(u); + /* if u == 0 then we have an exact subspace */ + if ( h_val <= 0.0 ) + { + *h_rem = h_val; + return H; + } + set_col(H,i,r); + if ( i == ip->k-1 ) + { + *h_rem = h_val; + continue; + } + /* H->me[i+1][i] = h_val; */ + m_set_val(H,i+1,i,h_val); + v.ve = Q->me[i+1]; + sv_mlt(1.0/h_val,u,&v); + } + + return H; +} + + + +/* iter_sparnoldi -- uses arnoldi() with an explicit representation of A */ +MAT *iter_sparnoldi(A,x0,m,h_rem,Q,H) +SPMAT *A; +VEC *x0; +int m; +Real *h_rem; +MAT *Q, *H; +{ + ITER *ip; + + ip = iter_get(0,0); + ip->Ax = (Fun_Ax) sp_mv_mlt; + ip->A_par = (void *) A; + ip->x = x0; + ip->k = m; + iter_arnoldi_iref(ip,h_rem,Q,H); + ip->shared_x = ip->shared_b = TRUE; + iter_free(ip); /* release only ITER structure */ + return H; +} + + +/* for testing gmres */ +static void test_gmres(ip,i,Q,R,givc,givs,h_val) +ITER *ip; +int i; +MAT *Q, *R; +VEC *givc, *givs; +double h_val; +{ + VEC vt, vt1; + static MAT *Q1, *R1; + int j; + + /* test Q*A*Q^T = R */ + + Q = m_resize(Q,i+1,ip->b->dim); + Q1 = m_resize(Q1,i+1,ip->b->dim); + R1 = m_resize(R1,i+1,i+1); + MEM_STAT_REG(Q1,TYPE_MAT); + MEM_STAT_REG(R1,TYPE_MAT); + + vt.dim = vt.max_dim = ip->b->dim; + vt1.dim = vt1.max_dim = ip->b->dim; + for (j=0; j <= i; j++) { + vt.ve = Q->me[j]; + vt1.ve = Q1->me[j]; + ip->Ax(ip->A_par,&vt,&vt1); + } + + mmtr_mlt(Q,Q1,R1); + R1 = m_resize(R1,i+2,i+1); + for (j=0; j < i; j++) + R1->me[i+1][j] = 0.0; + R1->me[i+1][i] = h_val; + + for (j = 0; j <= i; j++) { + rot_rows(R1,j,j+1,givc->ve[j],givs->ve[j],R1); + } + + R1 = m_resize(R1,i+1,i+1); + m_sub(R,R1,R1); + /* if (m_norm_inf(R1) > MACHEPS*ip->b->dim) */ + printf(" %d. ||Q*A*Q^T - H|| = %g [cf. MACHEPS = %g]\n", + ip->steps,m_norm_inf(R1),MACHEPS); + + /* check Q*Q^T = I */ + + Q = m_resize(Q,i+1,ip->b->dim); + mmtr_mlt(Q,Q,R1); + for (j=0; j <= i; j++) + R1->me[j][j] -= 1.0; + if (m_norm_inf(R1) > MACHEPS*ip->b->dim) + printf(" ! m_norm_inf(Q*Q^T) = %g\n",m_norm_inf(R1)); + +} + + +/* gmres -- generalised minimum residual algorithm of Saad & Schultz + SIAM J. Sci. Stat. Comp. v.7, pp.856--869 (1986) +*/ +VEC *iter_gmres(ip) +ITER *ip; +{ + static VEC *u=VNULL, *r=VNULL, *rhs = VNULL; + static VEC *givs=VNULL, *givc=VNULL, *z = VNULL; + static MAT *Q = MNULL, *R = MNULL; + VEC *rr, v, v1; /* additional pointers (not real vectors) */ + int i,j, done; + Real nres; +/* Real last_h; */ + + if (ip == INULL) + error(E_NULL,"iter_gmres"); + if ( ! ip->Ax || ! ip->b ) + error(E_NULL,"iter_gmres"); + if ( ! ip->stop_crit ) + error(E_NULL,"iter_gmres"); + if ( ip->k <= 0 ) + error(E_BOUNDS,"iter_gmres"); + if (ip->x != VNULL && ip->x->dim != ip->b->dim) + error(E_SIZES,"iter_gmres"); + + r = v_resize(r,ip->k+1); + u = v_resize(u,ip->b->dim); + rhs = v_resize(rhs,ip->k+1); + givs = v_resize(givs,ip->k); /* Givens rotations */ + givc = v_resize(givc,ip->k); + + MEM_STAT_REG(r,TYPE_VEC); + MEM_STAT_REG(u,TYPE_VEC); + MEM_STAT_REG(rhs,TYPE_VEC); + MEM_STAT_REG(givs,TYPE_VEC); + MEM_STAT_REG(givc,TYPE_VEC); + + R = m_resize(R,ip->k+1,ip->k); + Q = m_resize(Q,ip->k,ip->b->dim); + MEM_STAT_REG(R,TYPE_MAT); + MEM_STAT_REG(Q,TYPE_MAT); + + if (ip->x == VNULL) { /* ip->x == 0 */ + ip->x = v_get(ip->b->dim); + ip->shared_x = FALSE; + } + + v.dim = v.max_dim = ip->b->dim; /* v and v1 are pointers to rows */ + v1.dim = v1.max_dim = ip->b->dim; /* of matrix Q */ + + if (ip->Bx != (Fun_Ax)NULL) { /* if precondition is defined */ + z = v_resize(z,ip->b->dim); + MEM_STAT_REG(z,TYPE_VEC); + } + + done = FALSE; + for (ip->steps = 0; ip->steps <= ip->limit; ) { + + /* restart */ + + ip->Ax(ip->A_par,ip->x,u); /* u = A*x */ + v_sub(ip->b,u,u); /* u = b - A*x */ + rr = u; /* rr is a pointer only */ + + if (ip->Bx) { + (ip->Bx)(ip->B_par,u,z); /* tmp = B*(b-A*x) */ + rr = z; + } + + nres = v_norm2(rr); + if (ip->steps == 0) { + if (ip->info) ip->info(ip,nres,VNULL,VNULL); + if ( ip->stop_crit(ip,nres,VNULL,VNULL) ) { + done = TRUE; + break; + } + } + else if (nres <= 0.0) break; + + v.ve = Q->me[0]; + sv_mlt(1.0/nres,rr,&v); + + v_zero(r); + v_zero(rhs); + rhs->ve[0] = nres; + + for ( i = 0; i < ip->k; i++ ) { + ip->steps++; + v.ve = Q->me[i]; + (ip->Ax)(ip->A_par,&v,u); + rr = u; + if (ip->Bx) { + (ip->Bx)(ip->B_par,u,z); + rr = z; + } + + if (i < ip->k - 1) { + v1.ve = Q->me[i+1]; + v_copy(rr,&v1); + for (j = 0; j <= i; j++) { + v.ve = Q->me[j]; + r->ve[j] = in_prod(&v,rr); + v_mltadd(&v1,&v,-r->ve[j],&v1); + } + + r->ve[i+1] = nres = v_norm2(&v1); + if (nres <= 0.0) { + warning(WARN_RES_LESS_0,"iter_gmres"); + break; + } + sv_mlt(1.0/nres,&v1,&v1); + } + else { /* i == ip->k - 1 */ + /* Q->me[ip->k] need not be computed */ + + for (j = 0; j <= i; j++) { + v.ve = Q->me[j]; + r->ve[j] = in_prod(&v,rr); + } + + nres = in_prod(rr,rr) - in_prod(r,r); + if (nres <= 0.0) { + warning(WARN_RES_LESS_0,"iter_gmres"); + break; + } + r->ve[i+1] = sqrt(nres); + } + + /* QR update */ + + /* last_h = r->ve[i+1]; */ /* for test only */ + for (j = 0; j < i; j++) + rot_vec(r,j,j+1,givc->ve[j],givs->ve[j],r); + givens(r->ve[i],r->ve[i+1],&givc->ve[i],&givs->ve[i]); + rot_vec(r,i,i+1,givc->ve[i],givs->ve[i],r); + rot_vec(rhs,i,i+1,givc->ve[i],givs->ve[i],rhs); + + set_col(R,i,r); + + nres = fabs((double) rhs->ve[i+1]); + if (ip->info) ip->info(ip,nres,VNULL,VNULL); + if ( ip->stop_crit(ip,nres,VNULL,VNULL) || + ip->steps >= ip->limit ) { + done = TRUE; + break; + } + } + + /* use ixi submatrix of R */ + + if (nres <= 0.0) { + i--; + done = TRUE; + } + if (i == ip->k) i = ip->k - 1; + + R = m_resize(R,i+1,i+1); + rhs = v_resize(rhs,i+1); + + /* test only */ + /* test_gmres(ip,i,Q,R,givc,givs,last_h); */ + + Usolve(R,rhs,rhs,0.0); /* solve a system: R*x = rhs */ + + /* new approximation */ + + for (j = 0; j <= i; j++) { + v.ve = Q->me[j]; + v_mltadd(ip->x,&v,rhs->ve[j],ip->x); + } + + if (done) break; + + /* back to old dimensions */ + + rhs = v_resize(rhs,ip->k+1); + R = m_resize(R,ip->k+1,ip->k); + + } + + return ip->x; +} + +/* iter_spgmres - a simple interface to iter_gmres */ + +VEC *iter_spgmres(A,B,b,tol,x,k,limit,steps) +SPMAT *A, *B; +VEC *b, *x; +double tol; +int *steps,k,limit; +{ + ITER *ip; + + ip = iter_get(0,0); + ip->Ax = (Fun_Ax) sp_mv_mlt; + ip->A_par = (void *) A; + if (B) { + ip->Bx = (Fun_Ax) sp_mv_mlt; + ip->B_par = (void *) B; + } + else { + ip->Bx = (Fun_Ax) NULL; + ip->B_par = NULL; + } + ip->k = k; + ip->limit = limit; + ip->info = (Fun_info) NULL; + ip->b = b; + ip->eps = tol; + ip->x = x; + iter_gmres(ip); + x = ip->x; + if (steps) *steps = ip->steps; + ip->shared_x = ip->shared_b = TRUE; + iter_free(ip); /* release only ITER structure */ + return x; +} + + +/* for testing mgcr */ +static void test_mgcr(ip,i,Q,R) +ITER *ip; +int i; +MAT *Q, *R; +{ + VEC vt, vt1; + static MAT *R1; + static VEC *r, *r1; + VEC *rr; + int k,j; + Real sm; + + + /* check Q*Q^T = I */ + vt.dim = vt.max_dim = ip->b->dim; + vt1.dim = vt1.max_dim = ip->b->dim; + + Q = m_resize(Q,i+1,ip->b->dim); + R1 = m_resize(R1,i+1,i+1); + r = v_resize(r,ip->b->dim); + r1 = v_resize(r1,ip->b->dim); + MEM_STAT_REG(R1,TYPE_MAT); + MEM_STAT_REG(r,TYPE_VEC); + MEM_STAT_REG(r1,TYPE_VEC); + + m_zero(R1); + for (k=1; k <= i; k++) + for (j=1; j <= i; j++) { + vt.ve = Q->me[k]; + vt1.ve = Q->me[j]; + R1->me[k][j] = in_prod(&vt,&vt1); + } + for (j=1; j <= i; j++) + R1->me[j][j] -= 1.0; + if (m_norm_inf(R1) > MACHEPS*ip->b->dim) + printf(" ! (mgcr:) m_norm_inf(Q*Q^T) = %g\n",m_norm_inf(R1)); + + /* check (r_i,Ap_j) = 0 for j <= i */ + + ip->Ax(ip->A_par,ip->x,r); + v_sub(ip->b,r,r); + rr = r; + if (ip->Bx) { + ip->Bx(ip->B_par,r,r1); + rr = r1; + } + + printf(" ||r|| = %g\n",v_norm2(rr)); + sm = 0.0; + for (j = 1; j <= i; j++) { + vt.ve = Q->me[j]; + sm = max(sm,in_prod(&vt,rr)); + } + if (sm >= MACHEPS*ip->b->dim) + printf(" ! (mgcr:) max_j (r,Ap_j) = %g\n",sm); + +} + + + + +/* + iter_mgcr -- modified generalized conjugate residual algorithm; + fast version of GCR; +*/ +VEC *iter_mgcr(ip) +ITER *ip; +{ + static VEC *As, *beta, *alpha, *z; + static MAT *N, *H; + + VEC *rr, v, s; /* additional pointer and structures */ + Real nres; /* norm of a residual */ + Real dd; /* coefficient d_i */ + int i,j; + int done; /* if TRUE then stop the iterative process */ + int dim; /* dimension of the problem */ + + /* ip cannot be NULL */ + if (ip == INULL) error(E_NULL,"mgcr"); + /* Ax, b and stopping criterion must be given */ + if (! ip->Ax || ! ip->b || ! ip->stop_crit) + error(E_NULL,"mgcr"); + /* at least one direction vector must exist */ + if ( ip->k <= 0) error(E_BOUNDS,"mgcr"); + /* if the vector x is given then b and x must have the same dimension */ + if ( ip->x && ip->x->dim != ip->b->dim) + error(E_SIZES,"mgcr"); + + dim = ip->b->dim; + As = v_resize(As,dim); + alpha = v_resize(alpha,ip->k); + beta = v_resize(beta,ip->k); + + MEM_STAT_REG(As,TYPE_VEC); + MEM_STAT_REG(alpha,TYPE_VEC); + MEM_STAT_REG(beta,TYPE_VEC); + + H = m_resize(H,ip->k,ip->k); + N = m_resize(N,ip->k,dim); + + MEM_STAT_REG(H,TYPE_MAT); + MEM_STAT_REG(N,TYPE_MAT); + + /* if a preconditioner is defined */ + if (ip->Bx) { + z = v_resize(z,dim); + MEM_STAT_REG(z,TYPE_VEC); + } + + /* if x is NULL then it is assumed that x has + entries with value zero */ + if ( ! ip->x ) { + ip->x = v_get(ip->b->dim); + ip->shared_x = FALSE; + } + + /* v and s are additional pointers to rows of N */ + /* they must have the same dimension as rows of N */ + v.dim = v.max_dim = s.dim = s.max_dim = dim; + + + done = FALSE; + ip->steps = 0; + while (TRUE) { + (*ip->Ax)(ip->A_par,ip->x,As); /* As = A*x */ + v_sub(ip->b,As,As); /* As = b - A*x */ + rr = As; /* rr is an additional pointer */ + + /* if a preconditioner is defined */ + if (ip->Bx) { + (*ip->Bx)(ip->B_par,As,z); /* z = B*(b-A*x) */ + rr = z; + } + + /* norm of the residual */ + nres = v_norm2(rr); + dd = nres*nres; /* dd = ||r_i||^2 */ + + /* we need to check if the norm of the residual is small enough + only when we start the iterative process; + otherwise it has been checked yet. + Also the member ip->init_res is updated indirectly by + ip->stop_crit. + */ + if (ip->steps == 0) { /* information for a user */ + if (ip->info) (*ip->info)(ip,nres,As,rr); + if ( (*ip->stop_crit)(ip,nres,As,rr) ) { + /* iterative process is finished */ + done = TRUE; + break; + } + } + else if (nres <= 0.0) + break; /* residual is zero -> finish the process */ + + /* save this residual in the first row of N */ + v.ve = N->me[0]; + v_copy(rr,&v); + + for (i = 0; i < ip->k && ip->steps <= ip->limit; i++) { + ip->steps++; + v.ve = N->me[i]; /* pointer to a row of N (=s_i) */ + /* note that we must use here &v, not v */ + (*ip->Ax)(ip->A_par,&v,As); + rr = As; /* As = A*s_i */ + if (ip->Bx) { + (*ip->Bx)(ip->B_par,As,z); /* z = B*A*s_i */ + rr = z; + } + + if (i < ip->k - 1) { + s.ve = N->me[i+1]; /* pointer to a row of N (=s_{i+1}) */ + v_copy(rr,&s); /* s_{i+1} = B*A*s_i */ + for (j = 0; j <= i-1; j++) { + v.ve = N->me[j+1]; /* pointer to a row of N (=s_{j+1}) */ + beta->ve[j] = in_prod(&v,rr); /* beta_{j,i} */ + /* s_{i+1} -= beta_{j,i}*s_{j+1} */ + v_mltadd(&s,&v,- beta->ve[j],&s); + } + + /* beta_{i,i} = ||s_{i+1}||_2 */ + beta->ve[i] = nres = v_norm2(&s); + if ( nres <= 0.0) break; /* if s_{i+1} == 0 then finish */ + sv_mlt(1.0/nres,&s,&s); /* normalize s_{i+1} */ + + v.ve = N->me[0]; + alpha->ve[i] = in_prod(&v,&s); /* alpha_i = (s_0 , s_{i+1}) */ + + } + else { + for (j = 0; j <= i-1; j++) { + v.ve = N->me[j+1]; /* pointer to a row of N (=s_{j+1}) */ + beta->ve[j] = in_prod(&v,rr); /* beta_{j,i} */ + } + + nres = in_prod(rr,rr); /* rr = B*A*s_{k-1} */ + for (j = 0; j <= i-1; j++) + nres -= beta->ve[j]*beta->ve[j]; + if (nres <= 0.0) break; /* s_k is zero */ + else beta->ve[i] = sqrt(nres); /* beta_{k-1,k-1} */ + + v.ve = N->me[0]; + alpha->ve[i] = in_prod(&v,rr); + for (j = 0; j <= i-1; j++) + alpha->ve[i] -= beta->ve[j]*alpha->ve[j]; + alpha->ve[i] /= beta->ve[i]; /* alpha_{k-1} */ + + } + + set_col(H,i,beta); + + dd -= alpha->ve[i]*alpha->ve[i]; + nres = sqrt(fabs((double) dd)); + if (dd < 0.0) { /* do restart */ + if (ip->info) (*ip->info)(ip,-nres,VNULL,VNULL); + break; + } + + if (ip->info) (*ip->info)(ip,nres,VNULL,VNULL); + if ( ip->stop_crit(ip,nres,VNULL,VNULL) ) { + /* stopping criterion is satisfied */ + done = TRUE; + break; + } + + } /* end of for */ + + if (nres <= 0.0) { + i--; + done = TRUE; + } + if (i >= ip->k) i = ip->k - 1; + + /* use (i+1) by (i+1) submatrix of H */ + H = m_resize(H,i+1,i+1); + alpha = v_resize(alpha,i+1); + Usolve(H,alpha,alpha,0.0); /* c_i is saved in alpha */ + + for (j = 0; j <= i; j++) { + v.ve = N->me[j]; + v_mltadd(ip->x,&v,alpha->ve[j],ip->x); + } + + + if (done) break; /* stop the iterative process */ + alpha = v_resize(alpha,ip->k); + H = m_resize(H,ip->k,ip->k); + + } /* end of while */ + + return ip->x; /* return the solution */ +} + + + +/* iter_spmgcr - a simple interface to iter_mgcr */ +/* no preconditioner */ +VEC *iter_spmgcr(A,B,b,tol,x,k,limit,steps) +SPMAT *A, *B; +VEC *b, *x; +double tol; +int *steps,k,limit; +{ + ITER *ip; + + ip = iter_get(0,0); + ip->Ax = (Fun_Ax) sp_mv_mlt; + ip->A_par = (void *) A; + if (B) { + ip->Bx = (Fun_Ax) sp_mv_mlt; + ip->B_par = (void *) B; + } + else { + ip->Bx = (Fun_Ax) NULL; + ip->B_par = NULL; + } + + ip->k = k; + ip->limit = limit; + ip->info = (Fun_info) NULL; + ip->b = b; + ip->eps = tol; + ip->x = x; + iter_mgcr(ip); + x = ip->x; + if (steps) *steps = ip->steps; + ip->shared_x = ip->shared_b = TRUE; + iter_free(ip); /* release only ITER structure */ + return x; +} + + + +/* + Conjugate gradients method for a normal equation + a preconditioner B must be symmetric !! +*/ +VEC *iter_cgne(ip) +ITER *ip; +{ + static VEC *r = VNULL, *p = VNULL, *q = VNULL, *z = VNULL; + Real alpha, beta, inner, old_inner, nres; + VEC *rr1; /* pointer only */ + + if (ip == INULL) + error(E_NULL,"iter_cgne"); + if (!ip->Ax || ! ip->ATx || !ip->b) + error(E_NULL,"iter_cgne"); + if ( ip->x == ip->b ) + error(E_INSITU,"iter_cgne"); + if (!ip->stop_crit) + error(E_NULL,"iter_cgne"); + + if ( ip->eps <= 0.0 ) + ip->eps = MACHEPS; + + r = v_resize(r,ip->b->dim); + p = v_resize(p,ip->b->dim); + q = v_resize(q,ip->b->dim); + + MEM_STAT_REG(r,TYPE_VEC); + MEM_STAT_REG(p,TYPE_VEC); + MEM_STAT_REG(q,TYPE_VEC); + + z = v_resize(z,ip->b->dim); + MEM_STAT_REG(z,TYPE_VEC); + + if (ip->x) { + if (ip->x->dim != ip->b->dim) + error(E_SIZES,"iter_cgne"); + ip->Ax(ip->A_par,ip->x,p); /* p = A*x */ + v_sub(ip->b,p,z); /* z = b - A*x */ + } + else { /* ip->x == 0 */ + ip->x = v_get(ip->b->dim); + ip->shared_x = FALSE; + v_copy(ip->b,z); + } + rr1 = z; + if (ip->Bx) { + (ip->Bx)(ip->B_par,rr1,p); + rr1 = p; + } + (ip->ATx)(ip->AT_par,rr1,r); /* r = A^T*B*(b-A*x) */ + + + old_inner = 0.0; + for ( ip->steps = 0; ip->steps <= ip->limit; ip->steps++ ) + { + rr1 = r; + if ( ip->Bx ) { + (ip->Bx)(ip->B_par,r,z); /* rr = B*r */ + rr1 = z; + } + + inner = in_prod(r,rr1); + nres = sqrt(fabs(inner)); + if (ip->info) ip->info(ip,nres,r,rr1); + if ( ip->stop_crit(ip,nres,r,rr1) ) break; + + if ( ip->steps ) /* if ( ip->steps > 0 ) ... */ + { + beta = inner/old_inner; + p = v_mltadd(rr1,p,beta,p); + } + else /* if ( ip->steps == 0 ) ... */ + { + beta = 0.0; + p = v_copy(rr1,p); + old_inner = 0.0; + } + (ip->Ax)(ip->A_par,p,q); /* q = A*p */ + if (ip->Bx) { + (ip->Bx)(ip->B_par,q,z); + (ip->ATx)(ip->AT_par,z,q); + rr1 = q; /* q = A^T*B*A*p */ + } + else { + (ip->ATx)(ip->AT_par,q,z); /* z = A^T*A*p */ + rr1 = z; + } + + alpha = inner/in_prod(rr1,p); + v_mltadd(ip->x,p,alpha,ip->x); + v_mltadd(r,rr1,-alpha,r); + old_inner = inner; + } + + return ip->x; +} + +/* iter_spcgne -- a simple interface to iter_cgne() which + uses sparse matrix data structures + -- assumes that B contains an actual preconditioner (or NULL) + use always as follows: + x = iter_spcgne(A,B,b,eps,x,limit,steps); + or + x = iter_spcgne(A,B,b,eps,VNULL,limit,steps); + In the second case the solution vector is created. +*/ +VEC *iter_spcgne(A,B,b,eps,x,limit,steps) +SPMAT *A, *B; +VEC *b, *x; +double eps; +int *steps, limit; +{ + ITER *ip; + + ip = iter_get(0,0); + ip->Ax = (Fun_Ax) sp_mv_mlt; + ip->A_par = (void *)A; + ip->ATx = (Fun_Ax) sp_vm_mlt; + ip->AT_par = (void *)A; + if (B) { + ip->Bx = (Fun_Ax) sp_mv_mlt; + ip->B_par = (void *)B; + } + else { + ip->Bx = (Fun_Ax) NULL; + ip->B_par = NULL; + } + ip->info = (Fun_info) NULL; + ip->b = b; + ip->eps = eps; + ip->limit = limit; + ip->x = x; + iter_cgne(ip); + x = ip->x; + if (steps) *steps = ip->steps; + ip->shared_x = ip->shared_b = TRUE; + iter_free(ip); /* release only ITER structure */ + return x; +} + + + + diff --git a/meschach/itersym.c b/meschach/itersym.c new file mode 100644 index 0000000..c64f85f --- /dev/null +++ b/meschach/itersym.c @@ -0,0 +1,584 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* itersym.c 17/09/93 */ + + +/* + ITERATIVE METHODS - implementation of several iterative methods; + see also iter0.c + */ + +#include +#include +#include "matrix.h" +#include "matrix2.h" +#include "sparse.h" +#include "iter.h" + +static char rcsid[] = "$Id: itersym.c,v 1.1 2001/03/01 17:18:40 rfranke Exp $"; + + +#ifdef ANSI_C +VEC *spCHsolve(SPMAT *,VEC *,VEC *); +VEC *trieig(VEC *,VEC *,MAT *); +#else +VEC *spCHsolve(); +VEC *trieig(); +#endif + + + +/* iter_spcg -- a simple interface to iter_cg() which uses sparse matrix + data structures + -- assumes that LLT contains the Cholesky factorisation of the + actual preconditioner; + use always as follows: + x = iter_spcg(A,LLT,b,eps,x,limit,steps); + or + x = iter_spcg(A,LLT,b,eps,VNULL,limit,steps); + In the second case the solution vector is created. + */ +VEC *iter_spcg(A,LLT,b,eps,x,limit,steps) +SPMAT *A, *LLT; +VEC *b, *x; +double eps; +int *steps, limit; +{ + ITER *ip; + + ip = iter_get(0,0); + ip->Ax = (Fun_Ax) sp_mv_mlt; + ip->A_par = (void *)A; + ip->Bx = (Fun_Ax) spCHsolve; + ip->B_par = (void *)LLT; + ip->info = (Fun_info) NULL; + ip->b = b; + ip->eps = eps; + ip->limit = limit; + ip->x = x; + iter_cg(ip); + x = ip->x; + if (steps) *steps = ip->steps; + ip->shared_x = ip->shared_b = TRUE; + iter_free(ip); /* release only ITER structure */ + return x; +} + +/* + Conjugate gradients method; + */ +VEC *iter_cg(ip) +ITER *ip; +{ + static VEC *r = VNULL, *p = VNULL, *q = VNULL, *z = VNULL; + Real alpha, beta, inner, old_inner, nres; + VEC *rr; /* rr == r or rr == z */ + + if (ip == INULL) + error(E_NULL,"iter_cg"); + if (!ip->Ax || !ip->b) + error(E_NULL,"iter_cg"); + if ( ip->x == ip->b ) + error(E_INSITU,"iter_cg"); + if (!ip->stop_crit) + error(E_NULL,"iter_cg"); + + if ( ip->eps <= 0.0 ) + ip->eps = MACHEPS; + + r = v_resize(r,ip->b->dim); + p = v_resize(p,ip->b->dim); + q = v_resize(q,ip->b->dim); + + MEM_STAT_REG(r,TYPE_VEC); + MEM_STAT_REG(p,TYPE_VEC); + MEM_STAT_REG(q,TYPE_VEC); + + if (ip->Bx != (Fun_Ax)NULL) { + z = v_resize(z,ip->b->dim); + MEM_STAT_REG(z,TYPE_VEC); + rr = z; + } + else rr = r; + + if (ip->x != VNULL) { + if (ip->x->dim != ip->b->dim) + error(E_SIZES,"iter_cg"); + ip->Ax(ip->A_par,ip->x,p); /* p = A*x */ + v_sub(ip->b,p,r); /* r = b - A*x */ + } + else { /* ip->x == 0 */ + ip->x = v_get(ip->b->dim); + ip->shared_x = FALSE; + v_copy(ip->b,r); + } + + old_inner = 0.0; + for ( ip->steps = 0; ip->steps <= ip->limit; ip->steps++ ) + { + if ( ip->Bx ) + (ip->Bx)(ip->B_par,r,rr); /* rr = B*r */ + + inner = in_prod(rr,r); + nres = sqrt(fabs(inner)); + if (ip->info) ip->info(ip,nres,r,rr); + if ( ip->stop_crit(ip,nres,r,rr) ) break; + + if ( ip->steps ) /* if ( ip->steps > 0 ) ... */ + { + beta = inner/old_inner; + p = v_mltadd(rr,p,beta,p); + } + else /* if ( ip->steps == 0 ) ... */ + { + beta = 0.0; + p = v_copy(rr,p); + old_inner = 0.0; + } + (ip->Ax)(ip->A_par,p,q); /* q = A*p */ + alpha = inner/in_prod(p,q); + v_mltadd(ip->x,p,alpha,ip->x); + v_mltadd(r,q,-alpha,r); + old_inner = inner; + } + + return ip->x; +} + + + +/* iter_lanczos -- raw lanczos algorithm -- no re-orthogonalisation + -- creates T matrix of size == m, + but no larger than before beta_k == 0 + -- uses passed routine to do matrix-vector multiplies */ +void iter_lanczos(ip,a,b,beta2,Q) +ITER *ip; +VEC *a, *b; +Real *beta2; +MAT *Q; +{ + int j; + static VEC *v = VNULL, *w = VNULL, *tmp = VNULL; + Real alpha, beta, c; + + if ( ! ip ) + error(E_NULL,"iter_lanczos"); + if ( ! ip->Ax || ! ip->x || ! a || ! b ) + error(E_NULL,"iter_lanczos"); + if ( ip->k <= 0 ) + error(E_BOUNDS,"iter_lanczos"); + if ( Q && ( Q->n < ip->x->dim || Q->m < ip->k ) ) + error(E_SIZES,"iter_lanczos"); + + a = v_resize(a,(u_int)ip->k); + b = v_resize(b,(u_int)(ip->k-1)); + v = v_resize(v,ip->x->dim); + w = v_resize(w,ip->x->dim); + tmp = v_resize(tmp,ip->x->dim); + MEM_STAT_REG(v,TYPE_VEC); + MEM_STAT_REG(w,TYPE_VEC); + MEM_STAT_REG(tmp,TYPE_VEC); + + beta = 1.0; + v_zero(a); + v_zero(b); + if (Q) m_zero(Q); + + /* normalise x as w */ + c = v_norm2(ip->x); + if (c <= MACHEPS) { /* ip->x == 0 */ + *beta2 = 0.0; + return; + } + else + sv_mlt(1.0/c,ip->x,w); + + (ip->Ax)(ip->A_par,w,v); + + for ( j = 0; j < ip->k; j++ ) + { + /* store w in Q if Q not NULL */ + if ( Q ) set_row(Q,j,w); + + alpha = in_prod(w,v); + a->ve[j] = alpha; + v_mltadd(v,w,-alpha,v); + beta = v_norm2(v); + if ( beta == 0.0 ) + { + *beta2 = 0.0; + return; + } + + if ( j < ip->k-1 ) + b->ve[j] = beta; + v_copy(w,tmp); + sv_mlt(1/beta,v,w); + sv_mlt(-beta,tmp,v); + (ip->Ax)(ip->A_par,w,tmp); + v_add(v,tmp,v); + } + *beta2 = beta; + +} + +/* iter_splanczos -- version that uses sparse matrix data structure */ +void iter_splanczos(A,m,x0,a,b,beta2,Q) +SPMAT *A; +int m; +VEC *x0, *a, *b; +Real *beta2; +MAT *Q; +{ + ITER *ip; + + ip = iter_get(0,0); + ip->shared_x = ip->shared_b = TRUE; + ip->Ax = (Fun_Ax) sp_mv_mlt; + ip->A_par = (void *) A; + ip->x = x0; + ip->k = m; + iter_lanczos(ip,a,b,beta2,Q); + iter_free(ip); /* release only ITER structure */ +} + + + +extern double frexp(), ldexp(); + +/* product -- returns the product of a long list of numbers + -- answer stored in mant (mantissa) and expt (exponent) */ +static double product(a,offset,expt) +VEC *a; +double offset; +int *expt; +{ + Real mant, tmp_fctr; + int i, tmp_expt; + + if ( ! a ) + error(E_NULL,"product"); + + mant = 1.0; + *expt = 0; + if ( offset == 0.0 ) + for ( i = 0; i < a->dim; i++ ) + { + mant *= frexp(a->ve[i],&tmp_expt); + *expt += tmp_expt; + if ( ! (i % 10) ) + { + mant = frexp(mant,&tmp_expt); + *expt += tmp_expt; + } + } + else + for ( i = 0; i < a->dim; i++ ) + { + tmp_fctr = a->ve[i] - offset; + tmp_fctr += (tmp_fctr > 0.0 ) ? -MACHEPS*offset : + MACHEPS*offset; + mant *= frexp(tmp_fctr,&tmp_expt); + *expt += tmp_expt; + if ( ! (i % 10) ) + { + mant = frexp(mant,&tmp_expt); + *expt += tmp_expt; + } + } + + mant = frexp(mant,&tmp_expt); + *expt += tmp_expt; + + return mant; +} + +/* product2 -- returns the product of a long list of numbers + -- answer stored in mant (mantissa) and expt (exponent) */ +static double product2(a,k,expt) +VEC *a; +int k; /* entry of a to leave out */ +int *expt; +{ + Real mant, mu, tmp_fctr; + int i, tmp_expt; + + if ( ! a ) + error(E_NULL,"product2"); + if ( k < 0 || k >= a->dim ) + error(E_BOUNDS,"product2"); + + mant = 1.0; + *expt = 0; + mu = a->ve[k]; + for ( i = 0; i < a->dim; i++ ) + { + if ( i == k ) + continue; + tmp_fctr = a->ve[i] - mu; + tmp_fctr += ( tmp_fctr > 0.0 ) ? -MACHEPS*mu : MACHEPS*mu; + mant *= frexp(tmp_fctr,&tmp_expt); + *expt += tmp_expt; + if ( ! (i % 10) ) + { + mant = frexp(mant,&tmp_expt); + *expt += tmp_expt; + } + } + mant = frexp(mant,&tmp_expt); + *expt += tmp_expt; + + return mant; +} + +/* dbl_cmp -- comparison function to pass to qsort() */ +static int dbl_cmp(x,y) +Real *x, *y; +{ + Real tmp; + + tmp = *x - *y; + return (tmp > 0 ? 1 : tmp < 0 ? -1: 0); +} + +/* iter_lanczos2 -- lanczos + error estimate for every e-val + -- uses Cullum & Willoughby approach, Sparse Matrix Proc. 1978 + -- returns multiple e-vals where multiple e-vals may not exist + -- returns evals vector */ +VEC *iter_lanczos2(ip,evals,err_est) +ITER *ip; /* ITER structure */ +VEC *evals; /* eigenvalue vector */ +VEC *err_est; /* error estimates of eigenvalues */ +{ + VEC *a; + static VEC *b=VNULL, *a2=VNULL, *b2=VNULL; + Real beta, pb_mant, det_mant, det_mant1, det_mant2; + int i, pb_expt, det_expt, det_expt1, det_expt2; + + if ( ! ip ) + error(E_NULL,"iter_lanczos2"); + if ( ! ip->Ax || ! ip->x ) + error(E_NULL,"iter_lanczos2"); + if ( ip->k <= 0 ) + error(E_RANGE,"iter_lanczos2"); + + a = evals; + a = v_resize(a,(u_int)ip->k); + b = v_resize(b,(u_int)(ip->k-1)); + MEM_STAT_REG(b,TYPE_VEC); + + iter_lanczos(ip,a,b,&beta,MNULL); + + /* printf("# beta =%g\n",beta); */ + pb_mant = 0.0; + if ( err_est ) + { + pb_mant = product(b,(double)0.0,&pb_expt); + /* printf("# pb_mant = %g, pb_expt = %d\n",pb_mant, pb_expt); */ + } + + /* printf("# diags =\n"); v_output(a); */ + /* printf("# off diags =\n"); v_output(b); */ + a2 = v_resize(a2,a->dim - 1); + b2 = v_resize(b2,b->dim - 1); + MEM_STAT_REG(a2,TYPE_VEC); + MEM_STAT_REG(b2,TYPE_VEC); + for ( i = 0; i < a2->dim - 1; i++ ) + { + a2->ve[i] = a->ve[i+1]; + b2->ve[i] = b->ve[i+1]; + } + a2->ve[a2->dim-1] = a->ve[a2->dim]; + + trieig(a,b,MNULL); + + /* sort evals as a courtesy */ + qsort((void *)(a->ve),(int)(a->dim),sizeof(Real),(int (*)())dbl_cmp); + + /* error estimates */ + if ( err_est ) + { + err_est = v_resize(err_est,(u_int)ip->k); + + trieig(a2,b2,MNULL); + /* printf("# a =\n"); v_output(a); */ + /* printf("# a2 =\n"); v_output(a2); */ + + for ( i = 0; i < a->dim; i++ ) + { + det_mant1 = product2(a,i,&det_expt1); + det_mant2 = product(a2,(double)a->ve[i],&det_expt2); + /* printf("# det_mant1=%g, det_expt1=%d\n", + det_mant1,det_expt1); */ + /* printf("# det_mant2=%g, det_expt2=%d\n", + det_mant2,det_expt2); */ + if ( det_mant1 == 0.0 ) + { /* multiple e-val of T */ + err_est->ve[i] = 0.0; + continue; + } + else if ( det_mant2 == 0.0 ) + { + err_est->ve[i] = HUGE; + continue; + } + if ( (det_expt1 + det_expt2) % 2 ) + /* if odd... */ + det_mant = sqrt(2.0*fabs(det_mant1*det_mant2)); + else /* if even... */ + det_mant = sqrt(fabs(det_mant1*det_mant2)); + det_expt = (det_expt1+det_expt2)/2; + err_est->ve[i] = fabs(beta* + ldexp(pb_mant/det_mant,pb_expt-det_expt)); + } + } + + return a; +} + +/* iter_splanczos2 -- version of iter_lanczos2() that uses sparse matrix data + structure */ + +VEC *iter_splanczos2(A,m,x0,evals,err_est) +SPMAT *A; +int m; +VEC *x0; /* initial vector */ +VEC *evals; /* eigenvalue vector */ +VEC *err_est; /* error estimates of eigenvalues */ +{ + ITER *ip; + VEC *a; + + ip = iter_get(0,0); + ip->Ax = (Fun_Ax) sp_mv_mlt; + ip->A_par = (void *) A; + ip->x = x0; + ip->k = m; + a = iter_lanczos2(ip,evals,err_est); + ip->shared_x = ip->shared_b = TRUE; + iter_free(ip); /* release only ITER structure */ + return a; +} + + + + +/* + Conjugate gradient method + Another variant - mainly for testing + */ + +VEC *iter_cg1(ip) +ITER *ip; +{ + static VEC *r = VNULL, *p = VNULL, *q = VNULL, *z = VNULL; + Real alpha; + double inner,nres; + VEC *rr; /* rr == r or rr == z */ + + if (ip == INULL) + error(E_NULL,"iter_cg"); + if (!ip->Ax || !ip->b) + error(E_NULL,"iter_cg"); + if ( ip->x == ip->b ) + error(E_INSITU,"iter_cg"); + if (!ip->stop_crit) + error(E_NULL,"iter_cg"); + + if ( ip->eps <= 0.0 ) + ip->eps = MACHEPS; + + r = v_resize(r,ip->b->dim); + p = v_resize(p,ip->b->dim); + q = v_resize(q,ip->b->dim); + + MEM_STAT_REG(r,TYPE_VEC); + MEM_STAT_REG(p,TYPE_VEC); + MEM_STAT_REG(q,TYPE_VEC); + + if (ip->Bx != (Fun_Ax)NULL) { + z = v_resize(z,ip->b->dim); + MEM_STAT_REG(z,TYPE_VEC); + rr = z; + } + else rr = r; + + if (ip->x != VNULL) { + if (ip->x->dim != ip->b->dim) + error(E_SIZES,"iter_cg"); + ip->Ax(ip->A_par,ip->x,p); /* p = A*x */ + v_sub(ip->b,p,r); /* r = b - A*x */ + } + else { /* ip->x == 0 */ + ip->x = v_get(ip->b->dim); + ip->shared_x = FALSE; + v_copy(ip->b,r); + } + + if (ip->Bx) (ip->Bx)(ip->B_par,r,p); + else v_copy(r,p); + + inner = in_prod(p,r); + nres = sqrt(fabs(inner)); + if (ip->info) ip->info(ip,nres,r,p); + if ( ip->stop_crit(ip,nres,r,p) ) return ip->x; + + for ( ip->steps = 0; ip->steps <= ip->limit; ip->steps++ ) + { + ip->Ax(ip->A_par,p,q); + inner = in_prod(q,p); + if (inner <= 0.0) { + warning(WARN_RES_LESS_0,"iter_cg"); + break; + } + alpha = in_prod(p,r)/inner; + v_mltadd(ip->x,p,alpha,ip->x); + v_mltadd(r,q,-alpha,r); + + rr = r; + if (ip->Bx) { + ip->Bx(ip->B_par,r,z); + rr = z; + } + + nres = in_prod(r,rr); + if (nres < 0.0) { + warning(WARN_RES_LESS_0,"iter_cg"); + break; + } + nres = sqrt(fabs(nres)); + if (ip->info) ip->info(ip,nres,r,z); + if ( ip->stop_crit(ip,nres,r,z) ) break; + + alpha = -in_prod(rr,q)/inner; + v_mltadd(rr,p,alpha,p); + + } + + return ip->x; +} + diff --git a/meschach/itertort.c b/meschach/itertort.c new file mode 100644 index 0000000..0aed504 --- /dev/null +++ b/meschach/itertort.c @@ -0,0 +1,691 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* iter_tort.c 16/09/93 */ + +/* + This file contains tests for the iterative part of Meschach +*/ + +#include +#include +#include "matrix2.h" +#include "sparse2.h" +#include "iter.h" + +#define errmesg(mesg) printf("Error: %s error: line %d\n",mesg,__LINE__) +#define notice(mesg) printf("# Testing %s...\n",mesg); + + /* for iterative methods */ + +#if REAL == DOUBLE +#define EPS 1e-7 +#define KK 20 +#elif REAL == FLOAT +#define EPS 1e-5 +#define KK 8 +#endif + +#define ANON 513 +#define ASYM ANON + + +static VEC *ex_sol = VNULL; + +/* new iter information */ +void iter_mod_info(ip,nres,res,Bres) +ITER *ip; +double nres; +VEC *res, *Bres; +{ + static VEC *tmp; + + if (ip->b == VNULL) return; + tmp = v_resize(tmp,ip->b->dim); + MEM_STAT_REG(tmp,TYPE_VEC); + + if (nres >= 0.0) { + printf(" %d. residual = %g\n",ip->steps,nres); + } + else + printf(" %d. residual = %g (WARNING !!! should be >= 0) \n", + ip->steps,nres); + if (ex_sol != VNULL) + printf(" ||u_ex - u_approx||_2 = %g\n", + v_norm2(v_sub(ip->x,ex_sol,tmp))); +} + + +/* out = A^T*A*x */ +VEC *norm_equ(A,x,out) +SPMAT *A; +VEC *x, *out; +{ + static VEC * tmp; + + tmp = v_resize(tmp,x->dim); + MEM_STAT_REG(tmp,TYPE_VEC); + sp_mv_mlt(A,x,tmp); + sp_vm_mlt(A,tmp,out); + return out; + +} + + +/* + make symmetric preconditioner for nonsymmetric matrix A; + B = 0.5*(A+A^T) and then B is factorized using + incomplete Choleski factorization +*/ + +SPMAT *gen_sym_precond(A) +SPMAT *A; +{ + SPMAT *B; + SPROW *row; + int i,j,k; + Real val; + + B = sp_get(A->m,A->n,A->row[0].maxlen); + for (i=0; i < A->m; i++) { + row = &(A->row[i]); + for (j = 0; j < row->len; j++) { + k = row->elt[j].col; + if (i != k) { + val = 0.5*(sp_get_val(A,i,k) + sp_get_val(A,k,i)); + sp_set_val(B,i,k,val); + sp_set_val(B,k,i,val); + } + else { /* i == k */ + val = sp_get_val(A,i,i); + sp_set_val(B,i,i,val); + } + } + } + + spICHfactor(B); + return B; +} + +/* Dv_mlt -- diagonal by vector multiply; the diagonal matrix is represented + by a vector d */ +VEC *Dv_mlt(d, x, out) +VEC *d, *x, *out; +{ + int i; + + if ( ! d || ! x ) + error(E_NULL,"Dv_mlt"); + if ( d->dim != x->dim ) + error(E_SIZES,"Dv_mlt"); + out = v_resize(out,x->dim); + + for ( i = 0; i < x->dim; i++ ) + out->ve[i] = d->ve[i]*x->ve[i]; + + return out; +} + + + +/************************************************/ +void main(argc, argv) +int argc; +char *argv[]; +{ + VEC *x, *y, *z, *u, *v, *xn, *yn; + SPMAT *A = NULL, *B = NULL; + SPMAT *An = NULL, *Bn = NULL; + int i, k, kk, j; + ITER *ips, *ips1, *ipns, *ipns1; + MAT *Q, *H, *Q1, *H1; + VEC vt, vt1; + Real hh; + + + mem_info_on(TRUE); + notice("allocating sparse matrices"); + + printf(" dim of A = %dx%d\n",ASYM,ASYM); + + A = iter_gen_sym(ASYM,8); + B = sp_copy(A); + spICHfactor(B); + + u = v_get(A->n); + x = v_get(A->n); + y = v_get(A->n); + v = v_get(A->n); + + v_rand(x); + sp_mv_mlt(A,x,y); + ex_sol = x; + + notice(" initialize ITER variables"); + /* ips for symmetric matrices with precondition */ + ips = iter_get(A->m,A->n); + + /* printf(" ips:\n"); + iter_dump(stdout,ips); */ + + ips->limit = 500; + ips->eps = EPS; + + iter_Ax(ips,sp_mv_mlt,A); + iter_Bx(ips,spCHsolve,B); + + ips->b = v_copy(y,ips->b); + v_rand(ips->x); + /* test of iter_resize */ + ips = iter_resize(ips,2*A->m,2*A->n); + ips = iter_resize(ips,A->m,A->n); + + /* printf(" ips:\n"); + iter_dump(stdout,ips); */ + + /* ips1 for symmetric matrices without precondition */ + ips1 = iter_get(0,0); + /* printf(" ips1:\n"); + iter_dump(stdout,ips1); */ + ITER_FREE(ips1); + + ips1 = iter_copy2(ips,ips1); + iter_Bx(ips1,NULL,NULL); + ips1->b = ips->b; + ips1->shared_b = TRUE; + /* printf(" ips1:\n"); + iter_dump(stdout,ips1); */ + + /* ipns for nonsymetric matrices with precondition */ + ipns = iter_copy(ips,INULL); + ipns->k = KK; + ipns->limit = 500; + ipns->info = NULL; + + An = iter_gen_nonsym_posdef(ANON,8); + Bn = gen_sym_precond(An); + xn = v_get(An->n); + yn = v_get(An->n); + v_rand(xn); + sp_mv_mlt(An,xn,yn); + ipns->b = v_copy(yn,ipns->b); + + iter_Ax(ipns, sp_mv_mlt,An); + iter_ATx(ipns, sp_vm_mlt,An); + iter_Bx(ipns, spCHsolve,Bn); + + /* printf(" ipns:\n"); + iter_dump(stdout,ipns); */ + + /* ipns1 for nonsymmetric matrices without precondition */ + ipns1 = iter_copy2(ipns,INULL); + ipns1->b = ipns->b; + ipns1->shared_b = TRUE; + iter_Bx(ipns1,NULL,NULL); + + /* printf(" ipns1:\n"); + iter_dump(stdout,ipns1); */ + + + /******* CG ********/ + + notice(" CG method without preconditioning"); + ips1->info = NULL; + mem_stat_mark(1); + iter_cg(ips1); + + k = ips1->steps; + z = ips1->x; + printf(" cg: no. of iter.steps = %d\n",k); + v_sub(z,x,u); + printf(" (cg:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", + v_norm2(u),EPS); + + notice(" CG method with ICH preconditioning"); + + ips->info = NULL; + v_zero(ips->x); + iter_cg(ips); + + k = ips->steps; + printf(" cg: no. of iter.steps = %d\n",k); + v_sub(ips->x,x,u); + printf(" (cg:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", + v_norm2(u),EPS); + + V_FREE(v); + if ((v = iter_spcg(A,B,y,EPS,VNULL,1000,&k)) == VNULL) + errmesg("CG method with precond.: NULL solution"); + + v_sub(ips->x,v,u); + if (v_norm2(u) >= EPS) { + errmesg("CG method with precond.: different solutions"); + printf(" diff. = %g\n",v_norm2(u)); + } + + + mem_stat_free(1); + printf(" spcg: # of iter. steps = %d\n",k); + v_sub(v,x,u); + printf(" (spcg:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", + v_norm2(u),EPS); + + + /*** CG FOR NORMAL EQUATION *****/ + + notice("CGNE method with ICH preconditioning (nonsymmetric case)"); + + /* ipns->info = iter_std_info; */ + ipns->info = NULL; + v_zero(ipns->x); + + mem_stat_mark(1); + iter_cgne(ipns); + + k = ipns->steps; + z = ipns->x; + printf(" cgne: no. of iter.steps = %d\n",k); + v_sub(z,xn,u); + printf(" (cgne:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", + v_norm2(u),EPS); + + notice("CGNE method without preconditioning (nonsymmetric case)"); + + v_rand(u); + u = iter_spcgne(An,NULL,yn,EPS,u,1000,&k); + + mem_stat_free(1); + printf(" spcgne: no. of iter.steps = %d\n",k); + v_sub(u,xn,u); + printf(" (spcgne:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", + v_norm2(u),EPS); + + /*** CGS *****/ + + notice("CGS method with ICH preconditioning (nonsymmetric case)"); + + v_zero(ipns->x); /* new init guess == 0 */ + + mem_stat_mark(1); + ipns->info = NULL; + v_rand(u); + iter_cgs(ipns,u); + + k = ipns->steps; + z = ipns->x; + printf(" cgs: no. of iter.steps = %d\n",k); + v_sub(z,xn,u); + printf(" (cgs:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", + v_norm2(u),EPS); + + notice("CGS method without preconditioning (nonsymmetric case)"); + + v_rand(u); + v_rand(v); + v = iter_spcgs(An,NULL,yn,u,EPS,v,1000,&k); + + mem_stat_free(1); + printf(" cgs: no. of iter.steps = %d\n",k); + v_sub(v,xn,u); + printf(" (cgs:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", + v_norm2(u),EPS); + + + + /*** LSQR ***/ + + notice("LSQR method (without preconditioning)"); + + v_rand(u); + v_free(ipns1->x); + ipns1->x = u; + ipns1->shared_x = TRUE; + ipns1->info = NULL; + mem_stat_mark(2); + z = iter_lsqr(ipns1); + + v_sub(xn,z,v); + k = ipns1->steps; + printf(" lsqr: # of iter. steps = %d\n",k); + printf(" (lsqr:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", + v_norm2(v),EPS); + + v_rand(u); + u = iter_splsqr(An,yn,EPS,u,1000,&k); + mem_stat_free(2); + + v_sub(xn,u,v); + printf(" splsqr: # of iter. steps = %d\n",k); + printf(" (splsqr:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", + v_norm2(v),EPS); + + + + /***** GMRES ********/ + + notice("GMRES method with ICH preconditioning (nonsymmetric case)"); + + v_zero(ipns->x); +/* ipns->info = iter_std_info; */ + ipns->info = NULL; + + mem_stat_mark(2); + z = iter_gmres(ipns); + v_sub(xn,z,v); + k = ipns->steps; + printf(" gmres: # of iter. steps = %d\n",k); + printf(" (gmres:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", + v_norm2(v),EPS); + + notice("GMRES method without preconditioning (nonsymmetric case)"); + V_FREE(v); + v = iter_spgmres(An,NULL,yn,EPS,VNULL,10,1004,&k); + mem_stat_free(2); + + v_sub(xn,v,v); + printf(" spgmres: # of iter. steps = %d\n",k); + printf(" (spgmres:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", + v_norm2(v),EPS); + + + + /**** MGCR *****/ + + notice("MGCR method with ICH preconditioning (nonsymmetric case)"); + + v_zero(ipns->x); + mem_stat_mark(2); + z = iter_mgcr(ipns); + v_sub(xn,z,v); + k = ipns->steps; + printf(" mgcr: # of iter. steps = %d\n",k); + printf(" (mgcr:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", + v_norm2(v),EPS); + + notice("MGCR method without preconditioning (nonsymmetric case)"); + V_FREE(v); + v = iter_spmgcr(An,NULL,yn,EPS,VNULL,10,1004,&k); + mem_stat_free(2); + + v_sub(xn,v,v); + printf(" spmgcr: # of iter. steps = %d\n",k); + printf(" (spmgcr:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", + v_norm2(v),EPS); + + + /***** ARNOLDI METHOD ********/ + + + notice("arnoldi method"); + + kk = ipns1->k = KK; + Q = m_get(kk,x->dim); + Q1 = m_get(kk,x->dim); + H = m_get(kk,kk); + v_rand(u); + ipns1->x = u; + ipns1->shared_x = TRUE; + mem_stat_mark(3); + iter_arnoldi_iref(ipns1,&hh,Q,H); + mem_stat_free(3); + + /* check the equality: + Q*A*Q^T = H; */ + + vt.dim = vt.max_dim = x->dim; + vt1.dim = vt1.max_dim = x->dim; + for (j=0; j < kk; j++) { + vt.ve = Q->me[j]; + vt1.ve = Q1->me[j]; + sp_mv_mlt(An,&vt,&vt1); + } + H1 = m_get(kk,kk); + mmtr_mlt(Q,Q1,H1); + m_sub(H,H1,H1); + if (m_norm_inf(H1) > MACHEPS*x->dim) + printf(" (arnoldi_iref) ||Q*A*Q^T - H|| = %g [cf. MACHEPS = %g]\n", + m_norm_inf(H1),MACHEPS); + + /* check Q*Q^T = I */ + + mmtr_mlt(Q,Q,H1); + for (j=0; j < kk; j++) + H1->me[j][j] -= 1.0; + if (m_norm_inf(H1) > MACHEPS*x->dim) + printf(" (arnoldi_iref) ||Q*Q^T - I|| = %g [cf. MACHEPS = %g]\n", + m_norm_inf(H1),MACHEPS); + + ipns1->x = u; + ipns1->shared_x = TRUE; + mem_stat_mark(3); + iter_arnoldi(ipns1,&hh,Q,H); + mem_stat_free(3); + + /* check the equality: + Q*A*Q^T = H; */ + + vt.dim = vt.max_dim = x->dim; + vt1.dim = vt1.max_dim = x->dim; + for (j=0; j < kk; j++) { + vt.ve = Q->me[j]; + vt1.ve = Q1->me[j]; + sp_mv_mlt(An,&vt,&vt1); + } + + mmtr_mlt(Q,Q1,H1); + m_sub(H,H1,H1); + if (m_norm_inf(H1) > MACHEPS*x->dim) + printf(" (arnoldi) ||Q*A*Q^T - H|| = %g [cf. MACHEPS = %g]\n", + m_norm_inf(H1),MACHEPS); + /* check Q*Q^T = I */ + mmtr_mlt(Q,Q,H1); + for (j=0; j < kk; j++) + H1->me[j][j] -= 1.0; + if (m_norm_inf(H1) > MACHEPS*x->dim) + printf(" (arnoldi) ||Q*Q^T - I|| = %g [cf. MACHEPS = %g]\n", + m_norm_inf(H1),MACHEPS); + + v_rand(u); + mem_stat_mark(3); + iter_sparnoldi(An,u,kk,&hh,Q,H); + mem_stat_free(3); + + /* check the equality: + Q*A*Q^T = H; */ + + vt.dim = vt.max_dim = x->dim; + vt1.dim = vt1.max_dim = x->dim; + for (j=0; j < kk; j++) { + vt.ve = Q->me[j]; + vt1.ve = Q1->me[j]; + sp_mv_mlt(An,&vt,&vt1); + } + + mmtr_mlt(Q,Q1,H1); + m_sub(H,H1,H1); + if (m_norm_inf(H1) > MACHEPS*x->dim) + printf(" (sparnoldi) ||Q*A*Q^T - H|| = %g [cf. MACHEPS = %g]\n", + m_norm_inf(H1),MACHEPS); + /* check Q*Q^T = I */ + mmtr_mlt(Q,Q,H1); + for (j=0; j < kk; j++) + H1->me[j][j] -= 1.0; + if (m_norm_inf(H1) > MACHEPS*x->dim) + printf(" (sparnoldi) ||Q*Q^T - I|| = %g [cf. MACHEPS = %g]\n", + m_norm_inf(H1),MACHEPS); + + + + /****** LANCZOS METHOD ******/ + + notice("lanczos method"); + kk = ipns1->k; + Q = m_resize(Q,kk,x->dim); + Q1 = m_resize(Q1,kk,x->dim); + H = m_resize(H,kk,kk); + ips1->k = kk; + v_rand(u); + v_free(ips1->x); + ips1->x = u; + ips1->shared_x = TRUE; + + mem_stat_mark(3); + iter_lanczos(ips1,x,y,&hh,Q); + mem_stat_free(3); + + /* check the equality: + Q*A*Q^T = H; */ + + vt.dim = vt1.dim = Q->n; + vt.max_dim = vt1.max_dim = Q->max_n; + Q1 = m_resize(Q1,Q->m,Q->n); + for (j=0; j < Q->m; j++) { + vt.ve = Q->me[j]; + vt1.ve = Q1->me[j]; + sp_mv_mlt(A,&vt,&vt1); + } + H1 = m_resize(H1,Q->m,Q->m); + H = m_resize(H,Q->m,Q->m); + mmtr_mlt(Q,Q1,H1); + + m_zero(H); + for (j=0; j < Q->m-1; j++) { + H->me[j][j] = x->ve[j]; + H->me[j][j+1] = H->me[j+1][j] = y->ve[j]; + } + H->me[Q->m-1][Q->m-1] = x->ve[Q->m-1]; + + m_sub(H,H1,H1); + if (m_norm_inf(H1) > MACHEPS*x->dim) + printf(" (lanczos) ||Q*A*Q^T - H|| = %g [cf. MACHEPS = %g]\n", + m_norm_inf(H1),MACHEPS); + + /* check Q*Q^T = I */ + + mmtr_mlt(Q,Q,H1); + for (j=0; j < Q->m; j++) + H1->me[j][j] -= 1.0; + if (m_norm_inf(H1) > MACHEPS*x->dim) + printf(" (lanczos) ||Q*Q^T - I|| = %g [cf. MACHEPS = %g]\n", + m_norm_inf(H1),MACHEPS); + + mem_stat_mark(3); + v_rand(u); + iter_splanczos(A,kk,u,x,y,&hh,Q); + mem_stat_free(3); + + /* check the equality: + Q*A*Q^T = H; */ + + vt.dim = vt1.dim = Q->n; + vt.max_dim = vt1.max_dim = Q->max_n; + Q1 = m_resize(Q1,Q->m,Q->n); + for (j=0; j < Q->m; j++) { + vt.ve = Q->me[j]; + vt1.ve = Q1->me[j]; + sp_mv_mlt(A,&vt,&vt1); + } + H1 = m_resize(H1,Q->m,Q->m); + H = m_resize(H,Q->m,Q->m); + mmtr_mlt(Q,Q1,H1); + for (j=0; j < Q->m-1; j++) { + H->me[j][j] = x->ve[j]; + H->me[j][j+1] = H->me[j+1][j] = y->ve[j]; + } + H->me[Q->m-1][Q->m-1] = x->ve[Q->m-1]; + + m_sub(H,H1,H1); + if (m_norm_inf(H1) > MACHEPS*x->dim) + printf(" (splanczos) ||Q*A*Q^T - H|| = %g [cf. MACHEPS = %g]\n", + m_norm_inf(H1),MACHEPS); + /* check Q*Q^T = I */ + mmtr_mlt(Q,Q,H1); + for (j=0; j < Q->m; j++) + H1->me[j][j] -= 1.0; + if (m_norm_inf(H1) > MACHEPS*x->dim) + printf(" (splanczos) ||Q*Q^T - I|| = %g [cf. MACHEPS = %g]\n", + m_norm_inf(H1),MACHEPS); + + + + /***** LANCZOS2 ****/ + + notice("lanczos2 method"); + kk = 50; /* # of dir. vectors */ + ips1->k = kk; + v_rand(u); + ips1->x = u; + ips1->shared_x = TRUE; + + for ( i = 0; i < xn->dim; i++ ) + xn->ve[i] = i; + iter_Ax(ips1,Dv_mlt,xn); + mem_stat_mark(3); + iter_lanczos2(ips1,y,v); + mem_stat_free(3); + + printf("# Number of steps of Lanczos algorithm = %d\n", kk); + printf("# Exact eigenvalues are 0, 1, 2, ..., %d\n",ANON-1); + printf("# Extreme eigenvalues should be accurate; \n"); + printf("# interior values usually are not.\n"); + printf("# approx e-vals =\n"); v_output(y); + printf("# Error in estimate of bottom e-vec (Lanczos) = %g\n", + fabs(v->ve[0])); + + mem_stat_mark(3); + v_rand(u); + iter_splanczos2(A,kk,u,y,v); + mem_stat_free(3); + + + /***** FINISHING *******/ + + notice("release ITER variables"); + + M_FREE(Q); + M_FREE(Q1); + M_FREE(H); + M_FREE(H1); + + ITER_FREE(ipns); + ITER_FREE(ips); + ITER_FREE(ipns1); + ITER_FREE(ips1); + SP_FREE(A); + SP_FREE(B); + SP_FREE(An); + SP_FREE(Bn); + + V_FREE(x); + V_FREE(y); + V_FREE(u); + V_FREE(v); + V_FREE(xn); + V_FREE(yn); + + printf("# Done testing (%s)\n",argv[0]); + mem_info(); +} diff --git a/meschach/ivecop.c b/meschach/ivecop.c new file mode 100644 index 0000000..fb96295 --- /dev/null +++ b/meschach/ivecop.c @@ -0,0 +1,434 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* ivecop.c */ + +#include +#include "matrix.h" + +static char rcsid[] = "$Id: ivecop.c,v 1.1 2001/03/01 17:18:42 rfranke Exp $"; + +static char line[MAXLINE]; + + + +/* iv_get -- get integer vector -- see also memory.c */ +IVEC *iv_get(dim) +int dim; +{ + IVEC *iv; + /* u_int i; */ + + if (dim < 0) + error(E_NEG,"iv_get"); + + if ((iv=NEW(IVEC)) == IVNULL ) + error(E_MEM,"iv_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_IVEC,0,sizeof(IVEC)); + mem_numvar(TYPE_IVEC,1); + } + + iv->dim = iv->max_dim = dim; + if ((iv->ive = NEW_A(dim,int)) == (int *)NULL ) + error(E_MEM,"iv_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_IVEC,0,dim*sizeof(int)); + } + + return (iv); +} + +/* iv_free -- returns iv & asoociated memory back to memory heap */ +int iv_free(iv) +IVEC *iv; +{ + if ( iv==IVNULL || iv->dim > MAXDIM ) + /* don't trust it */ + return (-1); + + if ( iv->ive == (int *)NULL ) { + if (mem_info_is_on()) { + mem_bytes(TYPE_IVEC,sizeof(IVEC),0); + mem_numvar(TYPE_IVEC,-1); + } + free((char *)iv); + } + else + { + if (mem_info_is_on()) { + mem_bytes(TYPE_IVEC,sizeof(IVEC)+iv->max_dim*sizeof(int),0); + mem_numvar(TYPE_IVEC,-1); + } + free((char *)iv->ive); + free((char *)iv); + } + + return (0); +} + +/* iv_resize -- returns the IVEC with dimension new_dim + -- iv is set to the zero vector */ +IVEC *iv_resize(iv,new_dim) +IVEC *iv; +int new_dim; +{ + int i; + + if (new_dim < 0) + error(E_NEG,"iv_resize"); + + if ( ! iv ) + return iv_get(new_dim); + + if (new_dim == iv->dim) + return iv; + + if ( new_dim > iv->max_dim ) + { + if (mem_info_is_on()) { + mem_bytes(TYPE_IVEC,iv->max_dim*sizeof(int), + new_dim*sizeof(int)); + } + iv->ive = RENEW(iv->ive,new_dim,int); + if ( ! iv->ive ) + error(E_MEM,"iv_resize"); + iv->max_dim = new_dim; + } + if ( iv->dim <= new_dim ) + for ( i = iv->dim; i < new_dim; i++ ) + iv->ive[i] = 0; + iv->dim = new_dim; + + return iv; +} + +/* iv_copy -- copy integer vector in to out + -- out created/resized if necessary */ +IVEC *iv_copy(in,out) +IVEC *in, *out; +{ + int i; + + if ( ! in ) + error(E_NULL,"iv_copy"); + out = iv_resize(out,in->dim); + for ( i = 0; i < in->dim; i++ ) + out->ive[i] = in->ive[i]; + + return out; +} + +/* iv_move -- move selected pieces of an IVEC + -- moves the length dim0 subvector with initial index i0 + to the corresponding subvector of out with initial index i1 + -- out is resized if necessary */ +IVEC *iv_move(in,i0,dim0,out,i1) +IVEC *in, *out; +int i0, dim0, i1; +{ + if ( ! in ) + error(E_NULL,"iv_move"); + if ( i0 < 0 || dim0 < 0 || i1 < 0 || + i0+dim0 > in->dim ) + error(E_BOUNDS,"iv_move"); + + if ( (! out) || i1+dim0 > out->dim ) + out = iv_resize(out,i1+dim0); + + MEM_COPY(&(in->ive[i0]),&(out->ive[i1]),dim0*sizeof(int)); + + return out; +} + +/* iv_add -- integer vector addition -- may be in-situ */ +IVEC *iv_add(iv1,iv2,out) +IVEC *iv1,*iv2,*out; +{ + u_int i; + int *out_ive, *iv1_ive, *iv2_ive; + + if ( iv1==IVNULL || iv2==IVNULL ) + error(E_NULL,"iv_add"); + if ( iv1->dim != iv2->dim ) + error(E_SIZES,"iv_add"); + if ( out==IVNULL || out->dim != iv1->dim ) + out = iv_resize(out,iv1->dim); + + out_ive = out->ive; + iv1_ive = iv1->ive; + iv2_ive = iv2->ive; + + for ( i = 0; i < iv1->dim; i++ ) + out_ive[i] = iv1_ive[i] + iv2_ive[i]; + + return (out); +} + + + +/* iv_sub -- integer vector addition -- may be in-situ */ +IVEC *iv_sub(iv1,iv2,out) +IVEC *iv1,*iv2,*out; +{ + u_int i; + int *out_ive, *iv1_ive, *iv2_ive; + + if ( iv1==IVNULL || iv2==IVNULL ) + error(E_NULL,"iv_sub"); + if ( iv1->dim != iv2->dim ) + error(E_SIZES,"iv_sub"); + if ( out==IVNULL || out->dim != iv1->dim ) + out = iv_resize(out,iv1->dim); + + out_ive = out->ive; + iv1_ive = iv1->ive; + iv2_ive = iv2->ive; + + for ( i = 0; i < iv1->dim; i++ ) + out_ive[i] = iv1_ive[i] - iv2_ive[i]; + + return (out); +} + +/* iv_foutput -- print a representation of iv on stream fp */ +void iv_foutput(fp,iv) +FILE *fp; +IVEC *iv; +{ + int i; + + fprintf(fp,"IntVector: "); + if ( iv == IVNULL ) + { + fprintf(fp,"**** NULL ****\n"); + return; + } + fprintf(fp,"dim: %d\n",iv->dim); + for ( i = 0; i < iv->dim; i++ ) + { + if ( (i+1) % 8 ) + fprintf(fp,"%8d ",iv->ive[i]); + else + fprintf(fp,"%8d\n",iv->ive[i]); + } + if ( i % 8 ) + fprintf(fp,"\n"); +} + + +/* iv_finput -- input integer vector from stream fp */ +IVEC *iv_finput(fp,x) +FILE *fp; +IVEC *x; +{ + IVEC *iiv_finput(),*biv_finput(); + + if ( isatty(fileno(fp)) ) + return iiv_finput(fp,x); + else + return biv_finput(fp,x); +} + +/* iiv_finput -- interactive input of IVEC iv */ +IVEC *iiv_finput(fp,iv) +FILE *fp; +IVEC *iv; +{ + u_int i,dim,dynamic; /* dynamic set if memory allocated here */ + + /* get dimension */ + if ( iv != (IVEC *)NULL && iv->dimdim; dynamic = FALSE; } + else + { + dynamic = TRUE; + do + { + fprintf(stderr,"IntVector: dim: "); + if ( fgets(line,MAXLINE,fp)==NULL ) + error(E_INPUT,"iiv_finput"); + } while ( sscanf(line,"%u",&dim)<1 || dim>MAXDIM ); + iv = iv_get(dim); + } + + /* input elements */ + for ( i=0; iive[i]); + if ( fgets(line,MAXLINE,fp)==NULL ) + error(E_INPUT,"iiv_finput"); + if ( (*line == 'b' || *line == 'B') && i > 0 ) + { i--; dynamic = FALSE; goto redo; } + if ( (*line == 'f' || *line == 'F') && i < dim-1 ) + { i++; dynamic = FALSE; goto redo; } + } while ( *line=='\0' || sscanf(line,"%d",&iv->ive[i]) < 1 ); + + return (iv); +} + +/* biv_finput -- batch-file input of IVEC iv */ +IVEC *biv_finput(fp,iv) +FILE *fp; +IVEC *iv; +{ + u_int i,dim; + int io_code; + + /* get dimension */ + skipjunk(fp); + if ((io_code=fscanf(fp," IntVector: dim:%u",&dim)) < 1 || + dim>MAXDIM ) + error(io_code==EOF ? 7 : 6,"biv_finput"); + + /* allocate memory if necessary */ + if ( iv==(IVEC *)NULL || iv->dimive[i])) < 1 ) + error(io_code==EOF ? 7 : 6,"biv_finput"); + + return (iv); +} + +/* iv_dump -- dumps all the contents of IVEC iv onto stream fp */ +void iv_dump(fp,iv) +FILE*fp; +IVEC*iv; +{ + int i; + + fprintf(fp,"IntVector: "); + if ( ! iv ) + { + fprintf(fp,"**** NULL ****\n"); + return; + } + fprintf(fp,"dim: %d, max_dim: %d\n",iv->dim,iv->max_dim); + fprintf(fp,"ive @ 0x%lx\n",(long)(iv->ive)); + for ( i = 0; i < iv->max_dim; i++ ) + { + if ( (i+1) % 8 ) + fprintf(fp,"%8d ",iv->ive[i]); + else + fprintf(fp,"%8d\n",iv->ive[i]); + } + if ( i % 8 ) + fprintf(fp,"\n"); +} + +#define MAX_STACK 60 + + +/* iv_sort -- sorts vector x, and generates permutation that gives the order + of the components; x = [1.3, 3.7, 0.5] -> [0.5, 1.3, 3.7] and + the permutation is order = [2, 0, 1]. + -- if order is NULL on entry then it is ignored + -- the sorted vector x is returned */ +IVEC *iv_sort(x, order) +IVEC *x; +PERM *order; +{ + int *x_ive, tmp, v; + /* int *order_pe; */ + int dim, i, j, l, r, tmp_i; + int stack[MAX_STACK], sp; + + if ( ! x ) + error(E_NULL,"v_sort"); + if ( order != PNULL && order->size != x->dim ) + order = px_resize(order, x->dim); + + x_ive = x->ive; + dim = x->dim; + if ( order != PNULL ) + px_ident(order); + + if ( dim <= 1 ) + return x; + + /* using quicksort algorithm in Sedgewick, + "Algorithms in C", Ch. 9, pp. 118--122 (1990) */ + sp = 0; + l = 0; r = dim-1; v = x_ive[0]; + for ( ; ; ) + { + while ( r > l ) + { + /* "i = partition(x_ive,l,r);" */ + v = x_ive[r]; + i = l-1; + j = r; + for ( ; ; ) + { + while ( x_ive[++i] < v ) + ; + while ( x_ive[--j] > v ) + ; + if ( i >= j ) break; + + tmp = x_ive[i]; + x_ive[i] = x_ive[j]; + x_ive[j] = tmp; + if ( order != PNULL ) + { + tmp_i = order->pe[i]; + order->pe[i] = order->pe[j]; + order->pe[j] = tmp_i; + } + } + tmp = x_ive[i]; + x_ive[i] = x_ive[r]; + x_ive[r] = tmp; + if ( order != PNULL ) + { + tmp_i = order->pe[i]; + order->pe[i] = order->pe[r]; + order->pe[r] = tmp_i; + } + + if ( i-l > r-i ) + { stack[sp++] = l; stack[sp++] = i-1; l = i+1; } + else + { stack[sp++] = i+1; stack[sp++] = r; r = i-1; } + } + + /* recursion elimination */ + if ( sp == 0 ) + break; + r = stack[--sp]; + l = stack[--sp]; + } + + return x; +} diff --git a/meschach/lanczos.c b/meschach/lanczos.c new file mode 100644 index 0000000..91e284e --- /dev/null +++ b/meschach/lanczos.c @@ -0,0 +1,323 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + File containing Lanczos type routines for finding eigenvalues + of large, sparse, symmetic matrices +*/ + +#include +#include +#include "matrix.h" +#include "sparse.h" + +static char rcsid[] = "$Id: lanczos.c,v 1.1 2001/03/01 17:18:42 rfranke Exp $"; + +#ifdef ANSI_C +extern VEC *trieig(VEC *,VEC *,MAT *); +#else +extern VEC *trieig(); +#endif + +/* lanczos -- raw lanczos algorithm -- no re-orthogonalisation + -- creates T matrix of size == m, + but no larger than before beta_k == 0 + -- uses passed routine to do matrix-vector multiplies */ +void lanczos(A_fn,A_params,m,x0,a,b,beta2,Q) +VEC *(*A_fn)(); /* VEC *(*A_fn)(void *A_params,VEC *in, VEC *out) */ +void *A_params; +int m; +VEC *x0, *a, *b; +Real *beta2; +MAT *Q; +{ + int j; + VEC *v, *w, *tmp; + Real alpha, beta; + + if ( ! A_fn || ! x0 || ! a || ! b ) + error(E_NULL,"lanczos"); + if ( m <= 0 ) + error(E_BOUNDS,"lanczos"); + if ( Q && ( Q->m < x0->dim || Q->n < m ) ) + error(E_SIZES,"lanczos"); + + a = v_resize(a,(u_int)m); b = v_resize(b,(u_int)(m-1)); + v = v_get(x0->dim); + w = v_get(x0->dim); + tmp = v_get(x0->dim); + + beta = 1.0; + /* normalise x0 as w */ + sv_mlt(1.0/v_norm2(x0),x0,w); + + (*A_fn)(A_params,w,v); + + for ( j = 0; j < m; j++ ) + { + /* store w in Q if Q not NULL */ + if ( Q ) + set_col(Q,j,w); + + alpha = in_prod(w,v); + a->ve[j] = alpha; + v_mltadd(v,w,-alpha,v); + beta = v_norm2(v); + if ( beta == 0.0 ) + { + v_resize(a,(u_int)j+1); + v_resize(b,(u_int)j); + *beta2 = 0.0; + if ( Q ) + Q = m_resize(Q,Q->m,j+1); + return; + } + if ( j < m-1 ) + b->ve[j] = beta; + v_copy(w,tmp); + sv_mlt(1/beta,v,w); + sv_mlt(-beta,tmp,v); + (*A_fn)(A_params,w,tmp); + v_add(v,tmp,v); + } + *beta2 = beta; + + + V_FREE(v); V_FREE(w); V_FREE(tmp); +} + +extern double frexp(), ldexp(); + +/* product -- returns the product of a long list of numbers + -- answer stored in mant (mantissa) and expt (exponent) */ +static double product(a,offset,expt) +VEC *a; +double offset; +int *expt; +{ + Real mant, tmp_fctr; + int i, tmp_expt; + + if ( ! a ) + error(E_NULL,"product"); + + mant = 1.0; + *expt = 0; + if ( offset == 0.0 ) + for ( i = 0; i < a->dim; i++ ) + { + mant *= frexp(a->ve[i],&tmp_expt); + *expt += tmp_expt; + if ( ! (i % 10) ) + { + mant = frexp(mant,&tmp_expt); + *expt += tmp_expt; + } + } + else + for ( i = 0; i < a->dim; i++ ) + { + tmp_fctr = a->ve[i] - offset; + tmp_fctr += (tmp_fctr > 0.0 ) ? -MACHEPS*offset : + MACHEPS*offset; + mant *= frexp(tmp_fctr,&tmp_expt); + *expt += tmp_expt; + if ( ! (i % 10) ) + { + mant = frexp(mant,&tmp_expt); + *expt += tmp_expt; + } + } + + mant = frexp(mant,&tmp_expt); + *expt += tmp_expt; + + return mant; +} + +/* product2 -- returns the product of a long list of numbers + -- answer stored in mant (mantissa) and expt (exponent) */ +static double product2(a,k,expt) +VEC *a; +int k; /* entry of a to leave out */ +int *expt; +{ + Real mant, mu, tmp_fctr; + int i, tmp_expt; + + if ( ! a ) + error(E_NULL,"product2"); + if ( k < 0 || k >= a->dim ) + error(E_BOUNDS,"product2"); + + mant = 1.0; + *expt = 0; + mu = a->ve[k]; + for ( i = 0; i < a->dim; i++ ) + { + if ( i == k ) + continue; + tmp_fctr = a->ve[i] - mu; + tmp_fctr += ( tmp_fctr > 0.0 ) ? -MACHEPS*mu : MACHEPS*mu; + mant *= frexp(tmp_fctr,&tmp_expt); + *expt += tmp_expt; + if ( ! (i % 10) ) + { + mant = frexp(mant,&tmp_expt); + *expt += tmp_expt; + } + } + mant = frexp(mant,&tmp_expt); + *expt += tmp_expt; + + return mant; +} + +/* dbl_cmp -- comparison function to pass to qsort() */ +static int dbl_cmp(x,y) +Real *x, *y; +{ + Real tmp; + + tmp = *x - *y; + return (tmp > 0 ? 1 : tmp < 0 ? -1: 0); +} + +/* lanczos2 -- lanczos + error estimate for every e-val + -- uses Cullum & Willoughby approach, Sparse Matrix Proc. 1978 + -- returns multiple e-vals where multiple e-vals may not exist + -- returns evals vector */ +VEC *lanczos2(A_fn,A_params,m,x0,evals,err_est) +VEC *(*A_fn)(); +void *A_params; +int m; +VEC *x0; /* initial vector */ +VEC *evals; /* eigenvalue vector */ +VEC *err_est; /* error estimates of eigenvalues */ +{ + VEC *a; + static VEC *b=VNULL, *a2=VNULL, *b2=VNULL; + Real beta, pb_mant, det_mant, det_mant1, det_mant2; + int i, pb_expt, det_expt, det_expt1, det_expt2; + + if ( ! A_fn || ! x0 ) + error(E_NULL,"lanczos2"); + if ( m <= 0 ) + error(E_RANGE,"lanczos2"); + + a = evals; + a = v_resize(a,(u_int)m); + b = v_resize(b,(u_int)(m-1)); + MEM_STAT_REG(b,TYPE_VEC); + + lanczos(A_fn,A_params,m,x0,a,b,&beta,MNULL); + + /* printf("# beta =%g\n",beta); */ + pb_mant = 0.0; + if ( err_est ) + { + pb_mant = product(b,(double)0.0,&pb_expt); + /* printf("# pb_mant = %g, pb_expt = %d\n",pb_mant, pb_expt); */ + } + + /* printf("# diags =\n"); out_vec(a); */ + /* printf("# off diags =\n"); out_vec(b); */ + a2 = v_resize(a2,a->dim - 1); + b2 = v_resize(b2,b->dim - 1); + MEM_STAT_REG(a2,TYPE_VEC); + MEM_STAT_REG(b2,TYPE_VEC); + for ( i = 0; i < a2->dim - 1; i++ ) + { + a2->ve[i] = a->ve[i+1]; + b2->ve[i] = b->ve[i+1]; + } + a2->ve[a2->dim-1] = a->ve[a2->dim]; + + trieig(a,b,MNULL); + + /* sort evals as a courtesy */ + qsort((void *)(a->ve),(int)(a->dim),sizeof(Real),(int (*)())dbl_cmp); + + /* error estimates */ + if ( err_est ) + { + err_est = v_resize(err_est,(u_int)m); + + trieig(a2,b2,MNULL); + /* printf("# a =\n"); out_vec(a); */ + /* printf("# a2 =\n"); out_vec(a2); */ + + for ( i = 0; i < a->dim; i++ ) + { + det_mant1 = product2(a,i,&det_expt1); + det_mant2 = product(a2,(double)a->ve[i],&det_expt2); + /* printf("# det_mant1=%g, det_expt1=%d\n", + det_mant1,det_expt1); */ + /* printf("# det_mant2=%g, det_expt2=%d\n", + det_mant2,det_expt2); */ + if ( det_mant1 == 0.0 ) + { /* multiple e-val of T */ + err_est->ve[i] = 0.0; + continue; + } + else if ( det_mant2 == 0.0 ) + { + err_est->ve[i] = HUGE; + continue; + } + if ( (det_expt1 + det_expt2) % 2 ) + /* if odd... */ + det_mant = sqrt(2.0*fabs(det_mant1*det_mant2)); + else /* if even... */ + det_mant = sqrt(fabs(det_mant1*det_mant2)); + det_expt = (det_expt1+det_expt2)/2; + err_est->ve[i] = fabs(beta* + ldexp(pb_mant/det_mant,pb_expt-det_expt)); + } + } + + return a; +} + +/* sp_lanczos -- version that uses sparse matrix data structure */ +void sp_lanczos(A,m,x0,a,b,beta2,Q) +SPMAT *A; +int m; +VEC *x0, *a, *b; +Real *beta2; +MAT *Q; +{ lanczos(sp_mv_mlt,A,m,x0,a,b,beta2,Q); } + +/* sp_lanczos2 -- version of lanczos2() that uses sparse matrix data + structure */ +VEC *sp_lanczos2(A,m,x0,evals,err_est) +SPMAT *A; +int m; +VEC *x0; /* initial vector */ +VEC *evals; /* eigenvalue vector */ +VEC *err_est; /* error estimates of eigenvalues */ +{ return lanczos2(sp_mv_mlt,A,m,x0,evals,err_est); } + diff --git a/meschach/lufactor.c b/meschach/lufactor.c new file mode 100644 index 0000000..94bbe6b --- /dev/null +++ b/meschach/lufactor.c @@ -0,0 +1,268 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Matrix factorisation routines to work with the other matrix files. +*/ + +/* LUfactor.c 1.5 11/25/87 */ +static char rcsid[] = "$Id: lufactor.c,v 1.1 2001/03/01 17:18:43 rfranke Exp $"; + +#include +#include +#include "matrix.h" +#include "matrix2.h" + + + +/* Most matrix factorisation routines are in-situ unless otherwise specified */ + +/* LUfactor -- gaussian elimination with scaled partial pivoting + -- Note: returns LU matrix which is A */ +MAT *LUfactor(A,pivot) +MAT *A; +PERM *pivot; +{ + u_int i, j, k, k_max, m, n; + int i_max; + Real **A_v, *A_piv, *A_row; + Real max1, temp; + static VEC *scale = VNULL; + + if ( A==(MAT *)NULL || pivot==(PERM *)NULL ) + error(E_NULL,"LUfactor"); + if ( pivot->size != A->m ) + error(E_SIZES,"LUfactor"); + m = A->m; n = A->n; + scale = v_resize(scale,A->m); + MEM_STAT_REG(scale,TYPE_VEC); + A_v = A->me; + + /* initialise pivot with identity permutation */ + for ( i=0; ipe[i] = i; + + /* set scale parameters */ + for ( i=0; ive[i] = max1; + } + + /* main loop */ + k_max = min(m,n)-1; + for ( k=0; kve[i] > 0.0 ) + { + temp = fabs(A_v[i][k])/scale->ve[i]; + if ( temp > max1 ) + { max1 = temp; i_max = i; } + } + + /* if no pivot then ignore column k... */ + if ( i_max == -1 ) + continue; + + /* do we pivot ? */ + if ( i_max != k ) /* yes we do... */ + { + px_transp(pivot,i_max,k); + for ( j=0; jm != A->n || A->n != b->dim ) + error(E_SIZES,"LUsolve"); + + x = v_resize(x,b->dim); + px_vec(pivot,b,x); /* x := P.b */ + Lsolve(A,x,x,1.0); /* implicit diagonal = 1 */ + Usolve(A,x,x,0.0); /* explicit diagonal */ + + return (x); +} + +/* LUTsolve -- given an LU factorisation in A, solve A^T.x=b */ +VEC *LUTsolve(LU,pivot,b,x) +MAT *LU; +PERM *pivot; +VEC *b,*x; +{ + if ( ! LU || ! b || ! pivot ) + error(E_NULL,"LUTsolve"); + if ( LU->m != LU->n || LU->n != b->dim ) + error(E_SIZES,"LUTsolve"); + + x = v_copy(b,x); + UTsolve(LU,x,x,0.0); /* explicit diagonal */ + LTsolve(LU,x,x,1.0); /* implicit diagonal = 1 */ + pxinv_vec(pivot,x,x); /* x := P^T.tmp */ + + return (x); +} + +/* m_inverse -- returns inverse of A, provided A is not too rank deficient + -- uses LU factorisation */ +MAT *m_inverse(A,out) +MAT *A, *out; +{ + int i; + static VEC *tmp = VNULL, *tmp2 = VNULL; + static MAT *A_cp = MNULL; + static PERM *pivot = PNULL; + + if ( ! A ) + error(E_NULL,"m_inverse"); + if ( A->m != A->n ) + error(E_SQUARE,"m_inverse"); + if ( ! out || out->m < A->m || out->n < A->n ) + out = m_resize(out,A->m,A->n); + + A_cp = m_copy(A,MNULL); + tmp = v_resize(tmp,A->m); + tmp2 = v_resize(tmp2,A->m); + pivot = px_resize(pivot,A->m); + MEM_STAT_REG(A_cp,TYPE_MAT); + MEM_STAT_REG(tmp, TYPE_VEC); + MEM_STAT_REG(tmp2,TYPE_VEC); + MEM_STAT_REG(pivot,TYPE_PERM); + tracecatch(LUfactor(A_cp,pivot),"m_inverse"); + for ( i = 0; i < A->n; i++ ) + { + v_zero(tmp); + tmp->ve[i] = 1.0; + tracecatch(LUsolve(A_cp,pivot,tmp,tmp2),"m_inverse"); + set_col(out,i,tmp2); + } + + return out; +} + +/* LUcondest -- returns an estimate of the condition number of LU given the + LU factorisation in compact form */ +double LUcondest(LU,pivot) +MAT *LU; +PERM *pivot; +{ + static VEC *y = VNULL, *z = VNULL; + Real cond_est, L_norm, U_norm, sum; + int i, j, n; + + if ( ! LU || ! pivot ) + error(E_NULL,"LUcondest"); + if ( LU->m != LU->n ) + error(E_SQUARE,"LUcondest"); + if ( LU->n != pivot->size ) + error(E_SIZES,"LUcondest"); + + n = LU->n; + y = v_resize(y,n); + z = v_resize(z,n); + MEM_STAT_REG(y,TYPE_VEC); + MEM_STAT_REG(z,TYPE_VEC); + + for ( i = 0; i < n; i++ ) + { + sum = 0.0; + for ( j = 0; j < i; j++ ) + sum -= LU->me[j][i]*y->ve[j]; + sum -= (sum < 0.0) ? 1.0 : -1.0; + if ( LU->me[i][i] == 0.0 ) + return HUGE_VAL; + y->ve[i] = sum / LU->me[i][i]; + } + + LTsolve(LU,y,y,1.0); + LUsolve(LU,pivot,y,z); + + /* now estimate norm of A (even though it is not directly available) */ + /* actually computes ||L||_inf.||U||_inf */ + U_norm = 0.0; + for ( i = 0; i < n; i++ ) + { + sum = 0.0; + for ( j = i; j < n; j++ ) + sum += fabs(LU->me[i][j]); + if ( sum > U_norm ) + U_norm = sum; + } + L_norm = 0.0; + for ( i = 0; i < n; i++ ) + { + sum = 1.0; + for ( j = 0; j < i; j++ ) + sum += fabs(LU->me[i][j]); + if ( sum > L_norm ) + L_norm = sum; + } + + tracecatch(cond_est = U_norm*L_norm*v_norm_inf(z)/v_norm_inf(y), + "LUcondest"); + + return cond_est; +} diff --git a/meschach/m_err.h b/meschach/m_err.h new file mode 100644 index 0000000..eb30b03 --- /dev/null +++ b/meschach/m_err.h @@ -0,0 +1,182 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* err.h 28/09/1993 */ +/* renamed to m_err.h, rf 12/05/2000 */ + +/* RCS id: $Id: m_err.h,v 1.1 2001/03/01 17:18:43 rfranke Exp $ */ + + +#ifndef M_ERRHEADER +#define M_ERRHEADER + + +#include +#include "machine.h" + +/* Error recovery */ + +extern jmp_buf restart; + + +/* max. # of error lists */ +#define ERR_LIST_MAX_LEN 10 + +/* main error functions */ +#ifndef ANSI_C +extern int ev_err(); /* main error handler */ +extern int set_err_flag(); /* for different ways of handling + errors, returns old value */ +extern int count_errs(); /* to avoid "too many errors" */ +extern int err_list_attach(); /* for attaching a list of errors */ +extern int err_is_list_attached(); /* checking if a list is attached */ +extern int err_list_free(); /* freeing a list of errors */ + +#else /* ANSI_C */ + +extern int ev_err(char *,int,int,char *,int); /* main error handler */ +extern int set_err_flag(int flag); /* for different ways of handling + errors, returns old value */ +extern int count_errs(int true_false); /* to avoid "too many errors" */ +extern int err_list_attach(int list_num, int list_len, + char **err_ptr,int warn); /* for attaching a list of errors */ +extern int err_is_list_attached(int list_num); /* checking if a list + is attached */ +extern int err_list_free(int list_num); /* freeing a list of errors */ + +#endif + + +/* error(E_TYPE,"myfunc") raises error type E_TYPE for function my_func() */ +#define error(err_num,fn_name) ev_err(__FILE__,err_num,__LINE__,fn_name,0) + +/* warning(WARN_TYPE,"myfunc") raises warning type WARN_TYPE for + function my_func() */ +#define warning(err_num,fn_name) ev_err(__FILE__,err_num,__LINE__,fn_name,1) + + +/* error flags */ +#define EF_EXIT 0 /* exit on error */ +#define EF_ABORT 1 /* abort (dump core) on error */ +#define EF_JUMP 2 /* jump on error */ +#define EF_SILENT 3 /* jump, but don't print message */ +#define ERREXIT() set_err_flag(EF_EXIT) +#define ERRABORT() set_err_flag(EF_ABORT) +/* don't print message */ +#define SILENTERR() if ( ! setjmp(restart) ) set_err_flag(EF_SILENT) +/* return here on error */ +#define ON_ERROR() if ( ! setjmp(restart) ) set_err_flag(EF_JUMP) + + +/* error types */ +#define E_UNKNOWN 0 +#define E_SIZES 1 +#define E_BOUNDS 2 +#define E_MEM 3 +#define E_SING 4 +#define E_POSDEF 5 +#define E_FORMAT 6 +#define E_INPUT 7 +#define E_NULL 8 +#define E_SQUARE 9 +#define E_RANGE 10 +#define E_INSITU2 11 +#define E_INSITU 12 +#define E_ITER 13 +#define E_CONV 14 +#define E_START 15 +#define E_SIGNAL 16 +#define E_INTERN 17 +#define E_EOF 18 +#define E_SHARED_VECS 19 +#define E_NEG 20 +#define E_OVERWRITE 21 + +/* warning types */ +#define WARN_UNKNOWN 0 +#define WARN_WRONG_TYPE 1 +#define WARN_NO_MARK 2 +#define WARN_RES_LESS_0 3 +#define WARN_SHARED_VEC 4 + + +/* error catching macros */ + +/* execute err_part if error errnum is raised while executing ok_part */ +#define m_catch(errnum,ok_part,err_part) \ + { jmp_buf _save; int _err_num, _old_flag; \ + _old_flag = set_err_flag(EF_SILENT); \ + MEM_COPY(restart,_save,sizeof(jmp_buf)); \ + if ( (_err_num=setjmp(restart)) == 0 ) \ + { ok_part; \ + set_err_flag(_old_flag); \ + MEM_COPY(_save,restart,sizeof(jmp_buf)); } \ + else if ( _err_num == errnum ) \ + { set_err_flag(_old_flag); \ + MEM_COPY(_save,restart,sizeof(jmp_buf)); \ + err_part; } \ + else { set_err_flag(_old_flag); \ + MEM_COPY(_save,restart,sizeof(jmp_buf)); \ + error(_err_num,"m_catch"); \ + } \ + } + + +/* execute err_part if any error raised while executing ok_part */ +#define catchall(ok_part,err_part) \ + { jmp_buf _save; int _err_num, _old_flag; \ + _old_flag = set_err_flag(EF_SILENT); \ + MEM_COPY(restart,_save,sizeof(jmp_buf)); \ + if ( (_err_num=setjmp(restart)) == 0 ) \ + { ok_part; \ + set_err_flag(_old_flag); \ + MEM_COPY(_save,restart,sizeof(jmp_buf)); } \ + else \ + { set_err_flag(_old_flag); \ + MEM_COPY(_save,restart,sizeof(jmp_buf)); \ + err_part; } \ + } + + +/* print message if error raised while executing ok_part, + then re-raise error to trace calls */ +#define tracecatch(ok_part,function) \ + { jmp_buf _save; int _err_num, _old_flag; \ + _old_flag = set_err_flag(EF_JUMP); \ + MEM_COPY(restart,_save,sizeof(jmp_buf)); \ + if ( (_err_num=setjmp(restart)) == 0 ) \ + { ok_part; \ + set_err_flag(_old_flag); \ + MEM_COPY(_save,restart,sizeof(jmp_buf)); } \ + else \ + { set_err_flag(_old_flag); \ + MEM_COPY(_save,restart,sizeof(jmp_buf)); \ + error(_err_num,function); } \ + } + + + +#endif /* ERRHEADER */ diff --git a/meschach/machine.c b/meschach/machine.c new file mode 100644 index 0000000..9e8ba27 --- /dev/null +++ b/meschach/machine.c @@ -0,0 +1,146 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Stewart & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + +/* + This file contains basic routines which are used by the functions + in meschach.a etc. + These are the routines that should be modified in order to take + full advantage of specialised architectures (pipelining, vector + processors etc). + */ + +static char *rcsid = "$Id: machine.c,v 1.1 2001/03/01 17:18:43 rfranke Exp $"; + +#include "machine.h" + +/* __ip__ -- inner product */ +double __ip__(dp1,dp2,len) +register Real *dp1, *dp2; +int len; +{ +#ifdef VUNROLL + register int len4; + register Real sum1, sum2, sum3; +#endif + register int i; + register Real sum; + + sum = 0.0; +#ifdef VUNROLL + sum1 = sum2 = sum3 = 0.0; + + len4 = len / 4; + len = len % 4; + + for ( i = 0; i < len4; i++ ) + { + sum += dp1[4*i]*dp2[4*i]; + sum1 += dp1[4*i+1]*dp2[4*i+1]; + sum2 += dp1[4*i+2]*dp2[4*i+2]; + sum3 += dp1[4*i+3]*dp2[4*i+3]; + } + sum += sum1 + sum2 + sum3; + dp1 += 4*len4; dp2 += 4*len4; +#endif + + for ( i = 0; i < len; i++ ) + sum += dp1[i]*dp2[i]; + + return sum; +} + +/* __mltadd__ -- scalar multiply and add c.f. v_mltadd() */ +void __mltadd__(dp1,dp2,s,len) +register Real *dp1, *dp2; +register double s; +register int len; +{ + register int i; +#ifdef VUNROLL + register int len4; + + len4 = len / 4; + len = len % 4; + for ( i = 0; i < len4; i++ ) + { + dp1[4*i] += s*dp2[4*i]; + dp1[4*i+1] += s*dp2[4*i+1]; + dp1[4*i+2] += s*dp2[4*i+2]; + dp1[4*i+3] += s*dp2[4*i+3]; + } + dp1 += 4*len4; dp2 += 4*len4; +#endif + + for ( i = 0; i < len; i++ ) + dp1[i] += s*dp2[i]; +} + +/* __smlt__ scalar multiply array c.f. sv_mlt() */ +void __smlt__(dp,s,out,len) +register Real *dp, *out; +register double s; +register int len; +{ + register int i; + for ( i = 0; i < len; i++ ) + out[i] = s*dp[i]; +} + +/* __add__ -- add arrays c.f. v_add() */ +void __add__(dp1,dp2,out,len) +register Real *dp1, *dp2, *out; +register int len; +{ + register int i; + for ( i = 0; i < len; i++ ) + out[i] = dp1[i] + dp2[i]; +} + +/* __sub__ -- subtract arrays c.f. v_sub() */ +void __sub__(dp1,dp2,out,len) +register Real *dp1, *dp2, *out; +register int len; +{ + register int i; + for ( i = 0; i < len; i++ ) + out[i] = dp1[i] - dp2[i]; +} + +/* __zero__ -- zeros an array of floating point numbers */ +void __zero__(dp,len) +register Real *dp; +register int len; +{ +#ifdef CHAR0ISDBL0 + /* if a floating point zero is equivalent to a string of nulls */ + MEM_ZERO((char *)dp,len*sizeof(Real)); +#else + /* else, need to zero the array entry by entry */ + int i; + for ( i = 0; i < len; i++ ) + dp[i] = 0.0; +#endif +} + diff --git a/meschach/machine.h b/meschach/machine.h new file mode 100644 index 0000000..18c92f6 --- /dev/null +++ b/meschach/machine.h @@ -0,0 +1,281 @@ +/* machine.h. Generated automatically by configure. */ +/* Any machine specific stuff goes here */ +/* Add details necessary for your own installation here! */ + +/* RCS id: $Id: machine.h,v 1.1 2001/03/01 17:18:44 rfranke Exp $ */ + +/* This is for use with "configure" -- if you are not using configure + then use machine.van for the "vanilla" version of machine.h */ + +/* Note special macros: ANSI_C (ANSI C syntax) + SEGMENTED (segmented memory machine e.g. MS-DOS) + MALLOCDECL (declared if malloc() etc have + been declared) */ + +/* #undef const */ + +/* #undef MALLOCDECL */ +#define NOT_SEGMENTED 1 +#define HAVE_MEMORY_H 1 +/* #undef HAVE_COMPLEX_H */ +#define HAVE_MALLOC_H 1 +/* #undef HAVE_SYS_CDEFS_H */ +#define STDC_HEADERS 1 +#define HAVE_BCOPY 1 +#define HAVE_BZERO 1 +#define CHAR0ISDBL0 1 +/* #undef WORDS_BIGENDIAN */ +/* #define U_INT_DEF 1 */ +#define HAVE_SYS_TYPES_H 1 +#define VARARGS 1 +#define HAVE_PROTOTYPES 1 +/* #undef HAVE_PROTOTYPES_IN_STRUCT */ + +/* for inclusion into C++ files */ +#ifdef __cplusplus +#define ANSI_C 1 +#ifndef HAVE_PROTOTYPES +#define HAVE_PROTOTYPES 1 +#endif +#ifndef HAVE_PROTOTYPES_IN_STRUCT +#define HAVE_PROTOTYPES_IN_STRUCT 1 +#endif +#endif /* __cplusplus */ + +/* example usage: VEC *PROTO(v_get,(int dim)); */ +#ifdef HAVE_PROTOTYPES +#define PROTO(name,args) name args +#else +#define PROTO(name,args) name() +#endif /* HAVE_PROTOTYPES */ +#ifdef HAVE_PROTOTYPES_IN_STRUCT +/* PROTO_() is to be used instead of PROTO() in struct's and typedef's */ +#define PROTO_(name,args) name args +#else +#define PROTO_(name,args) name() +#endif /* HAVE_PROTOTYPES_IN_STRUCT */ + +/* for basic or larger versions */ +#define COMPLEX 1 +#define SPARSE 1 + +/* for loop unrolling */ +#define VUNROLL 1 +#define MUNROLL 1 + +/* for segmented memory */ +#ifndef NOT_SEGMENTED +#define SEGMENTED +#endif + +/* if the system has sys/types.h */ +#ifdef HAVE_SYS_TYPES_H +#include +#endif + +/* if the system has malloc.h */ +#ifdef HAVE_MALLOC_H +#define MALLOCDECL 1 +#include +#endif + +/* any compiler should have this header */ +/* if not, change it */ +#include + + +/* Check for ANSI C memmove and memset */ +#ifdef STDC_HEADERS + +/* standard copy & zero functions */ +#define MEM_COPY(from,to,size) memmove((to),(from),(size)) +#define MEM_ZERO(where,size) memset((where),'\0',(size)) + +#ifndef ANSI_C +#define ANSI_C 1 +#endif + +#endif + +/* standard headers */ +#ifdef ANSI_C +#include +#include +#include +#include +/*---------- E. Arnold 1999-04-29 ----------*/ +#include +/*----------*/ +#endif + + +/* if have bcopy & bzero and no alternatives yet known, use them */ +#ifdef HAVE_BCOPY +#ifndef MEM_COPY +/* nonstandard copy function */ +#define MEM_COPY(from,to,size) bcopy((char *)(from),(char *)(to),(int)(size)) +#endif +#endif + +#ifdef HAVE_BZERO +#ifndef MEM_ZERO +/* nonstandard zero function */ +#define MEM_ZERO(where,size) bzero((char *)(where),(int)(size)) +#endif +#endif + +/* if the system has complex.h */ +#ifdef HAVE_COMPLEX_H +#include +#endif + +/* If prototypes are available & ANSI_C not yet defined, then define it, + but don't include any header files as the proper ANSI C headers + aren't here */ +#ifdef HAVE_PROTOTYPES +#ifndef ANSI_C +#define ANSI_C 1 +#endif +#endif + +/* floating point precision */ + +/* you can choose single, double or long double (if available) precision */ + +#define FLOAT 1 +#define DOUBLE 2 +#define LONG_DOUBLE 3 + +/* #undef REAL_FLT */ +/* #undef REAL_DBL */ + +/* if nothing is defined, choose double precision */ +#ifndef REAL_DBL +#ifndef REAL_FLT +#define REAL_DBL 1 +#endif +#endif + +/* single precision */ +#ifdef REAL_FLT +#define Real float +#define LongReal float +#define REAL FLOAT +#define LONGREAL FLOAT +#endif + +/* double precision */ +#ifdef REAL_DBL +#define Real double +#define LongReal double +#define REAL DOUBLE +#define LONGREAL DOUBLE +#endif + + +/* machine epsilon or unit roundoff error */ +/* This is correct on most IEEE Real precision systems */ +#ifdef DBL_EPSILON +#if REAL == DOUBLE +#define MACHEPS DBL_EPSILON +#elif REAL == FLOAT +#define MACHEPS FLT_EPSILON +#elif REAL == LONGDOUBLE +#define MACHEPS LDBL_EPSILON +#endif +#endif + +#define F_MACHEPS 1.19209e-07 +#define D_MACHEPS 2.22045e-16 + +#ifndef MACHEPS +#if REAL == DOUBLE +#define MACHEPS D_MACHEPS +#elif REAL == FLOAT +#define MACHEPS F_MACHEPS +#elif REAL == LONGDOUBLE +#define MACHEPS D_MACHEPS +#endif +#endif + +/* #undef M_MACHEPS */ + +/******************** +#ifdef DBL_EPSILON +#define MACHEPS DBL_EPSILON +#endif +#ifdef M_MACHEPS +#ifndef MACHEPS +#define MACHEPS M_MACHEPS +#endif +#endif +********************/ + +#define M_MAX_INT 2147483647 +#ifdef M_MAX_INT +#ifndef MAX_RAND +#define MAX_RAND ((double)(M_MAX_INT)) +#endif +#endif + +/* for non-ANSI systems */ +#ifndef HUGE_VAL +#define HUGE_VAL HUGE +/*---------- E. Arnold 1999-04-29 ----------*/ +/* #else */ +/* #undef HUGE */ +#endif +#ifndef HUGE +#define HUGE HUGE_VAL +/*----------*/ +#endif + + +/* setup C environment */ + +#ifdef HAVE_SYS_CDEFS_H +#include +#endif + +#ifndef __STDC__ +#ifdef __cplusplus +#define __STDC__ +#endif +#endif + +#ifndef MESCH__P +#ifdef __STDC__ +#define MESCH__P(protos) protos +#else +#define MESCH__P(protos) () +#endif +#endif + +/* for non-ANSI sources */ +#ifdef TRADITIONAL +#undef ANSI_C +#undef MESCH__P +#define MESCH__P(protos) () +#endif + +#ifndef MESCH__BEGIN_DECLS +#ifdef __cplusplus +#define MESCH__BEGIN_DECLS extern "C" { +#define MESCH__END_DECLS }; +#else +#define MESCH__BEGIN_DECLS +#define MESCH__END_DECLS +#endif +#endif + +/* use _setjmp if defined */ +#ifdef HAVE__SETJMP +#define setjmp(ENV) _setjmp(ENV) +#endif + +/*#define SPARSE_COL_ACCESS 1*/ + +/* modified files + * sparse.c: + * no function sp_col_access() + */ diff --git a/meschach/makefile b/meschach/makefile new file mode 100644 index 0000000..5dec56f --- /dev/null +++ b/meschach/makefile @@ -0,0 +1,215 @@ +# Generated automatically from makefile.in by configure. +# +# Makefile for Meschach via autoconf +# +# Copyright (C) David Stewart & Zbigniew Leyk 1993 +# +# $Id: makefile,v 1.1 2001/03/01 17:18:44 rfranke Exp $ +# + +include ../makedefs + +O = $(OBJ_SUFFIX) + +srcdir = . +VPATH = . + +CC = $(MES_CC) + +DEFS = $(MES_DEFS) +LIBS = -lm +#RANLIB = ranlib + + +CFLAGS = $(MES_CFLAGS) + + +.c$O: + $(CC) -c $(CFLAGS) $(DEFS) $< + +SHELL = /bin/sh +MES_PAK = mesch12b +TAR = tar +SHAR = stree -u +ZIP = zip -r -l +FLIST = FILELIST + +############################### + +LIST1 = copy$O err$O matrixio$O memory$O vecop$O matop$O pxop$O \ + submat$O init$O otherio$O machine$O matlab$O ivecop$O version$O \ + meminfo$O memstat$O +LIST2 = lufactor$O bkpfacto$O chfactor$O qrfactor$O solve$O hsehldr$O \ + givens$O update$O norm$O hessen$O symmeig$O schur$O svd$O fft$O \ + mfunc$O bdfactor$O +LIST3 = sparse$O sprow$O sparseio$O \ + iter0$O +# itersym$O iternsym$O +# spchfctr$O splufctr$O spbkp$O spswap$O +ZLIST1 = zmachine$O zcopy$O zmatio$O zmemory$O zvecop$O zmatop$O znorm$O \ + zfunc$O +ZLIST2 = zlufctr$O zsolve$O zmatlab$O zhsehldr$O zqrfctr$O \ + zgivens$O zhessen$O zschur$O + +# they are no longer supported +# if you use them add oldpart to all and sparse +OLDLIST = conjgrad$O lanczos$O arnoldi$O + +ALL_LISTS = $(LIST1) $(LIST2) $(LIST3) $(ZLIST1) $(ZLIST2) $(OLDLIST) + +HBASE = m_err.h meminfo.h machine.h matrix.h + +HLIST = $(HBASE) iter.h matlab.h matrix2.h oldnames.h sparse.h \ + sparse2.h zmatrix.h zmatrix2.h + +TORTURE = torture$O sptort$O ztorture$O memtort$O itertort$O \ + mfuntort$O iotort$O + +OTHERS = dmacheps.c extras.c fmacheps.c maxint.c makefile.in \ + README configure configure.in machine.h.in copyright \ + tutorial.c tutadv.c rk4.dat ls.dat makefile $(FLIST) + + +# Different configurations +# the dependencies **between** the parts are for dmake +all: part1 part2 part3 zpart1 zpart2 +part2: part1 +part3: part2 +basic: part1 part2 +sparse: part1 part2 part3 +zpart2: zpart1 +complex: part1 part2 zpart1 zpart2 + + +$(LIST1): $(HBASE) +part1: $(LIST1) +# ar ru meschach.a $(LIST1); $(RANLIB) meschach.a + +$(LIST2): $(HBASE) matrix2.h +part2: $(LIST2) +# ar ru meschach.a $(LIST2); $(RANLIB) meschach.a + +$(LIST3): $(HBASE) sparse.h sparse2.h +part3: $(LIST3) +# ar ru meschach.a $(LIST3); $(RANLIB) meschach.a + +$(ZLIST1): $(HBASDE) zmatrix.h +zpart1: $(ZLIST1) +# ar ru meschach.a $(ZLIST1); $(RANLIB) meschach.a + +$(ZLIST2): $(HBASE) zmatrix.h zmatrix2.h +zpart2: $(ZLIST2) +# ar ru meschach.a $(ZLIST2); $(RANLIB) meschach.a + +$(OLDLIST): $(HBASE) sparse.h sparse2.h +oldpart: $(OLDLIST) +# ar ru meschach.a $(OLDLIST); $(RANLIB) meschach.a + + + +####################################### + +tar: + - /bin/rm -f $(MES_PAK).tar + chmod 644 `echo $(ALL_LISTS) | sed -e 's/\$O/.c/g'` \ + $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\$O/.c/g'` + chmod 755 configure + $(MAKE) list + $(TAR) cvf $(MES_PAK).tar \ + `echo $(ALL_LISTS) | sed -e 's/\$O/.c/g'` \ + $(HLIST) $(OTHERS) \ + `echo $(TORTURE) | sed -e 's/\$O/.c/g'` \ + MACHINES DOC + +# use this only for PC machines +msdos-zip: + - /bin/rm -f $(MES_PAK).zip + chmod 644 `echo $(ALL_LISTS) | sed -e 's/\$O/.c/g'` \ + $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\$O/.c/g'` + chmod 755 configure + $(MAKE) list + $(ZIP) $(MES_PAK).zip \ + `echo $(ALL_LISTS) | sed -e 's/\$O/.c/g'` \ + $(HLIST) $(OTHERS) `echo $(TORTURE) | sed -e 's/\$O/.c/g'` \ + MACHINES DOC + + +fullshar: + - /bin/rm -f $(MES_PAK).shar; + chmod 644 `echo $(ALL_LISTS) | sed -e 's/\$O/.c/g'` \ + $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\$O/.c/g'` + chmod 755 configure + $(MAKE) list + $(SHAR) `echo $(ALL_LISTS) | sed -e 's/\$O/.c/g'` \ + $(HLIST) $(OTHERS) `echo $(TORTURE) | sed -e 's/\$O/.c/g'` \ + MACHINES DOC > $(MES_PAK).shar + +shar: + - /bin/rm -f meschach1.shar meschach2.shar meschach3.shar \ + meschach4.shar oldmeschach.shar meschach0.shar + chmod 644 `echo $(ALL_LISTS) | sed -e 's/\$O/.c/g'` \ + $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\$O/.c/g'` + chmod 755 configure + $(MAKE) list + $(SHAR) `echo $(LIST1) | sed -e 's/\$O/.c/g'` > meschach1.shar + $(SHAR) `echo $(LIST2) | sed -e 's/\$O/.c/g'` > meschach2.shar + $(SHAR) `echo $(LIST3) | sed -e 's/\$O/.c/g'` > meschach3.shar + $(SHAR) `echo $(ZLIST1) | sed -e 's/\$O/.c/g'` \ + `echo $(ZLIST2) | sed -e 's/\$O/.c/g'` > meschach4.shar + $(SHAR) `echo $(OLDLIST) | sed -e 's/\$O/.c/g'` > oldmeschach.shar + $(SHAR) $(OTHERS) `echo $(TORTURE) | sed -e 's/\$O/.c/g'` \ + $(HLIST) DOC MACHINES > meschach0.shar + +list: + /bin/rm -f $(FLIST) + ls -lR `echo $(ALL_LISTS) | sed -e 's/\$O/.c/g'` \ + `echo $(TORTURE) | sed -e 's/\$O/.c/g'` \ + $(HLIST) $(OTHERS) MACHINES DOC \ + |awk '/^$$/ {print};/^[-d]/ {printf("%s %s %10d %s %s %s %s\n", \ + $$1,$$2,$$5,$$6,$$7,$$8,$$9)}; /^[^-d]/ {print}' \ + > $(FLIST) + + + +clean: + /bin/rm -f *$O core asx5213a.mat iotort.dat + +cleanup: + /bin/rm -f *$O core asx5213a.mat iotort.dat *.a + +realclean: + /bin/rm -f *$O core asx5213a.mat iotort.dat *.a + /bin/rm -f torture sptort ztorture memtort itertort mfuntort iotort + /bin/rm -f makefile machine.h config.status maxint macheps + +alltorture: torture sptort ztorture memtort itertort mfuntort iotort + +torture:torture$O meschach.a + $(CC) $(CFLAGS) $(DEFS) -o torture torture$O \ + meschach.a $(LIBS) +sptort:sptort$O meschach.a + $(CC) $(CFLAGS) $(DEFS) -o sptort sptort$O \ + meschach.a $(LIBS) +memtort: memtort$O meschach.a + $(CC) $(CFLAGS) $(DEFS) -o memtort memtort$O \ + meschach.a $(LIBS) +ztorture:ztorture$O meschach.a + $(CC) $(CFLAGS) $(DEFS) -o ztorture ztorture$O \ + meschach.a $(LIBS) +itertort: itertort$O meschach.a + $(CC) $(CFLAGS) $(DEFS) -o itertort itertort$O \ + meschach.a $(LIBS) + +iotort: iotort$O meschach.a + $(CC) $(CFLAGS) $(DEFS) -o iotort iotort$O \ + meschach.a $(LIBS) +mfuntort: mfuntort$O meschach.a + $(CC) $(CFLAGS) $(DEFS) -o mfuntort mfuntort$O \ + meschach.a $(LIBS) +tstmove: tstmove$O meschach.a + $(CC) $(CFLAGS) $(DEFS) -o tstmove tstmove$O \ + meschach.a $(LIBS) +tstpxvec: tstpxvec$O meschach.a + $(CC) $(CFLAGS) $(DEFS) -o tstpxvec tstpxvec$O \ + meschach.a $(LIBS) + diff --git a/meschach/matdef.h b/meschach/matdef.h new file mode 100644 index 0000000..d18d796 --- /dev/null +++ b/meschach/matdef.h @@ -0,0 +1,133 @@ +/* + Type definitions for general purpose maths package +*/ +/* RCS id: $Header: /home/ruediger/hqp/hqp/meschach/matdef.h,v 1.1 2001/03/01 17:18:44 rfranke Exp $ */ + +#include "machine.h" + +#define TRUE 1 +#define FALSE 0 + +#ifndef RS6000 +/* this is defined in on RS6000/AIX systems */ +typedef unsigned int u_int; +#endif + +/* vector definition */ +typedef struct { + u_int dim, max_dim; + double *ve; + } VEC; +/* matrix definition */ +typedef struct { + u_int m, n; + u_int max_m, max_n, max_size; + double **me,*base; /* base is base of alloc'd mem */ + } MAT; +/* permutation definition */ +typedef struct { + u_int size, max_size, *pe; + } PERM; +/* integer vector definition */ +typedef struct { + u_int dim, max_dim; + int *ive; + } IVEC; + +#define VNULL ((VEC *)NULL) +#define MNULL ((MAT *)NULL) +#define PNULL ((PERM *)NULL) +#define IVNULL ((IVEC *)NULL) + +#define MAXDIM 2001 + +#ifndef MALLOCDECL +#ifndef ANSI_C +extern char *malloc(), *calloc(), *realloc(); +#else +extern void *malloc(size_t), + *calloc(size_t,size_t), + *realloc(void *,size_t); +#endif +#endif + +#define NEW(type) ((type *)calloc(1,sizeof(type))) +#define NEW_A(size,type) ((type *)calloc(size,sizeof(type))) +#define RENEW(var,num,type) \ + ((var)=(type *)((var) ? realloc((var),(num)*sizeof(type)) : \ + calloc((num),sizeof(type)))) + +/* useful things to have around... */ +#define min(a,b) ((a) < (b) ? (a) : (b)) +#define max(a,b) ((a) > (b) ? (a) : (b)) +#define PI 3.141592653589793 +#define E 2.718281828459045 +#define cp_vec(in,out) _cp_vec(in,out,0) +#define cp_mat(in,out) _cp_mat(in,out,0,0) +#define set_col(mat,col,vec) _set_col(mat,col,vec,0) +#define set_row(mat,row,vec) _set_row(mat,row,vec,0) + +/* for input routines */ +#define MAXLINE 81 +char line[MAXLINE]; + +/* Error recovery */ +#include +extern jmp_buf restart; +#ifdef ANSI_C +extern int ev_err(char *, int, int, char *); +#else +/* extern int ev_err(); */ +#endif +#define error(err_num,fn_name) ev_err(__FILE__,err_num,__LINE__,fn_name) +#define E_UNKNOWN 0 +#define E_SIZES 1 +#define E_BOUNDS 2 +#define E_MEM 3 +#define E_SING 4 +#define E_POSDEF 5 +#define E_FORMAT 6 +#define E_INPUT 7 +#define E_NULL 8 +#define E_SQUARE 9 +#define E_RANGE 10 +#define E_INSITU2 11 +#define E_INSITU 12 +#define E_ITER 13 +#define E_CONV 14 +#define E_START 15 +#define E_SIGNAL 16 +#define E_INTERN 17 +#define E_EOF 18 + +#define EF_EXIT 0 +#define EF_ABORT 1 +#define EF_JUMP 2 +#define EF_SILENT 3 +#define tracecatch(ok_part,function) \ + { jmp_buf _save; int _err_num, _old_flag; \ + _old_flag = set_err_flag(EF_JUMP); \ + mem_copy(restart,_save,sizeof(jmp_buf)); \ + if ( (_err_num=setjmp(restart)) == 0 ) \ + { ok_part; \ + set_err_flag(_old_flag); \ + mem_copy(_save,restart,sizeof(jmp_buf)); } \ + else \ + { set_err_flag(_old_flag); \ + mem_copy(_save,restart,sizeof(jmp_buf)); \ + error(_err_num,function); } \ + } + +#ifdef ANSI_C +extern double __ip__(double *, double *, int); +extern void __mltadd__(double *, double *, double, int); +extern void __smlt__(double *, double, double *, int); +extern void __add__(double *, double *, double *, int); +extern void __sub__(double *, double *, double *, int); +extern void __zero__(double *, int); +extern int set_err_flag(int); +#else +extern double __ip__(); +extern void __mltadd__(), __smlt__(), __add__(), __sub__(), __zero__(); +extern int set_err_flag(); +#endif diff --git a/meschach/matlab.c b/meschach/matlab.c new file mode 100644 index 0000000..e2307ff --- /dev/null +++ b/meschach/matlab.c @@ -0,0 +1,196 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + This file contains routines for import/exporting data to/from + MATLAB. The main routines are: + MAT *m_save(FILE *fp,MAT *A,char *name) + VEC *v_save(FILE *fp,VEC *x,char *name) + MAT *m_load(FILE *fp,char **name) +*/ + +#include +#include "matrix.h" +#include "matlab.h" + +static char rcsid[] = "$Id: matlab.c,v 1.1 2001/03/01 17:18:45 rfranke Exp $"; + +/* m_save -- save matrix in ".mat" file for MATLAB + -- returns matrix to be saved */ +MAT *m_save(fp,A,name) +FILE *fp; +MAT *A; +char *name; +{ + int i; + matlab mat; + + if ( ! A ) + error(E_NULL,"m_save"); + + mat.type = 1000*MACH_ID + 100*ORDER + 10*PRECISION + 0; + mat.m = A->m; + mat.n = A->n; + mat.imag = FALSE; + mat.namlen = (name == (char *)NULL) ? 1 : strlen(name)+1; + + /* write header */ + fwrite(&mat,sizeof(matlab),1,fp); + /* write name */ + if ( name == (char *)NULL ) + fwrite("",sizeof(char),1,fp); + else + fwrite(name,sizeof(char),(int)(mat.namlen),fp); + /* write actual data */ + for ( i = 0; i < A->m; i++ ) + fwrite(A->me[i],sizeof(Real),(int)(A->n),fp); + + return A; +} + + +/* v_save -- save vector in ".mat" file for MATLAB + -- saves it as a row vector + -- returns vector to be saved */ +VEC *v_save(fp,x,name) +FILE *fp; +VEC *x; +char *name; +{ + matlab mat; + + if ( ! x ) + error(E_NULL,"v_save"); + + mat.type = 1000*MACH_ID + 100*ORDER + 10*PRECISION + 0; + mat.m = x->dim; + mat.n = 1; + mat.imag = FALSE; + mat.namlen = (name == (char *)NULL) ? 1 : strlen(name)+1; + + /* write header */ + fwrite(&mat,sizeof(matlab),1,fp); + /* write name */ + if ( name == (char *)NULL ) + fwrite("",sizeof(char),1,fp); + else + fwrite(name,sizeof(char),(int)(mat.namlen),fp); + /* write actual data */ + fwrite(x->ve,sizeof(Real),(int)(x->dim),fp); + + return x; +} + +/* d_save -- save double in ".mat" file for MATLAB + -- saves it as a row vector + -- returns vector to be saved */ +double d_save(fp,x,name) +FILE *fp; +double x; +char *name; +{ + matlab mat; + Real x1 = x; + + mat.type = 1000*MACH_ID + 100*ORDER + 10*PRECISION + 0; + mat.m = 1; + mat.n = 1; + mat.imag = FALSE; + mat.namlen = (name == (char *)NULL) ? 1 : strlen(name)+1; + + /* write header */ + fwrite(&mat,sizeof(matlab),1,fp); + /* write name */ + if ( name == (char *)NULL ) + fwrite("",sizeof(char),1,fp); + else + fwrite(name,sizeof(char),(int)(mat.namlen),fp); + /* write actual data */ + fwrite(&x1,sizeof(Real),1,fp); + + return x; +} + +/* m_load -- loads in a ".mat" file variable as produced by MATLAB + -- matrix returned; imaginary parts ignored */ +MAT *m_load(fp,name) +FILE *fp; +char **name; +{ + MAT *A; + int i; + int m_flag, o_flag, p_flag, t_flag; + float f_temp; + Real d_temp; + matlab mat; + + if ( fread(&mat,sizeof(matlab),1,fp) != 1 ) + error(E_FORMAT,"m_load"); + if ( mat.type >= 10000 ) /* don't load a sparse matrix! */ + error(E_FORMAT,"m_load"); + m_flag = (mat.type/1000) % 10; + o_flag = (mat.type/100) % 10; + p_flag = (mat.type/10) % 10; + t_flag = (mat.type) % 10; + if ( m_flag != MACH_ID ) + error(E_FORMAT,"m_load"); + if ( t_flag != 0 ) + error(E_FORMAT,"m_load"); + if ( p_flag != DOUBLE_PREC && p_flag != SINGLE_PREC ) + error(E_FORMAT,"m_load"); + *name = (char *)malloc((unsigned)(mat.namlen)+1); + if ( fread(*name,sizeof(char),(unsigned)(mat.namlen),fp) == 0 ) + error(E_FORMAT,"m_load"); + A = m_get((unsigned)(mat.m),(unsigned)(mat.n)); + for ( i = 0; i < A->m*A->n; i++ ) + { + if ( p_flag == DOUBLE_PREC ) + fread(&d_temp,sizeof(double),1,fp); + else + { + fread(&f_temp,sizeof(float),1,fp); + d_temp = f_temp; + } + if ( o_flag == ROW_ORDER ) + A->me[i / A->n][i % A->n] = d_temp; + else if ( o_flag == COL_ORDER ) + A->me[i % A->m][i / A->m] = d_temp; + else + error(E_FORMAT,"m_load"); + } + + if ( mat.imag ) /* skip imaginary part */ + for ( i = 0; i < A->m*A->n; i++ ) + { + if ( p_flag == DOUBLE_PREC ) + fread(&d_temp,sizeof(double),1,fp); + else + fread(&f_temp,sizeof(float),1,fp); + } + + return A; +} + diff --git a/meschach/matlab.h b/meschach/matlab.h new file mode 100644 index 0000000..f5597b4 --- /dev/null +++ b/meschach/matlab.h @@ -0,0 +1,112 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* matlab.h -- Header file for matlab.c and spmatlab.c for save/load formats */ + +#ifndef MATLAB_DEF + +#define MATLAB_DEF + +/* structure required by MATLAB */ +typedef struct { + long type; /* matrix type */ + long m; /* # rows */ + long n; /* # cols */ + long imag; /* is complex? */ + long namlen; /* length of variable name */ + } matlab; + +/* macros for matrix storage type */ +#define INTEL 0 /* for 80x87 format */ +#define PC INTEL +#define MOTOROLA 1 /* 6888x format */ +#define SUN MOTOROLA +#define APOLLO MOTOROLA +#define MAC MOTOROLA +#define VAX_D 2 +#define VAX_G 3 + +#define COL_ORDER 0 +#define ROW_ORDER 1 + +#define DOUBLE_PREC 0 /* double precision */ +#define SINGLE_PREC 1 /* single precision */ +#define INT_32 2 /* 32 bit integers (signed) */ +#define INT_16 3 /* 16 bit integers (signed) */ +#define INT_16u 4 /* 16 bit integers (unsigned) */ +/* end of macros for matrix storage type */ + +#ifndef MACH_ID +#define MACH_ID MOTOROLA +#endif + +#define ORDER ROW_ORDER + +#if REAL == DOUBLE +#define PRECISION DOUBLE_PREC +#elif REAL == FLOAT +#define PRECISION SINGLE_PREC +#endif + + +/* prototypes */ + +#ifdef ANSI_C + +MAT *m_save(FILE *,MAT *,char *); +MAT *m_load(FILE *,char **); +VEC *v_save(FILE *,VEC *,char *); +double d_save(FILE *,double,char *); + +#else + +extern MAT *m_save(), *m_load(); +extern VEC *v_save(); +extern double d_save(); +#endif + +/* complex variant */ +#ifdef COMPLEX +#include "zmatrix.h" + +#ifdef ANSI_C +extern ZMAT *zm_save(FILE *fp,ZMAT *A,char *name); +extern ZVEC *zv_save(FILE *fp,ZVEC *x,char *name); +extern complex z_save(FILE *fp,complex z,char *name); +extern ZMAT *zm_load(FILE *fp,char **name); + +#else + +extern ZMAT *zm_save(); +extern ZVEC *zv_save(); +extern complex z_save(); +extern ZMAT *zm_load(); + +#endif + +#endif + +#endif diff --git a/meschach/matop.c b/meschach/matop.c new file mode 100644 index 0000000..600eb2a --- /dev/null +++ b/meschach/matop.c @@ -0,0 +1,495 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* matop.c 1.3 11/25/87 */ + + +#include +#include "matrix.h" + +static char rcsid[] = "$Id: matop.c,v 1.1 2001/03/01 17:18:46 rfranke Exp $"; + + +/* m_add -- matrix addition -- may be in-situ */ +MAT *m_add(mat1,mat2,out) +MAT *mat1,*mat2,*out; +{ + u_int m,n,i; + + if ( mat1==(MAT *)NULL || mat2==(MAT *)NULL ) + error(E_NULL,"m_add"); + if ( mat1->m != mat2->m || mat1->n != mat2->n ) + error(E_SIZES,"m_add"); + if ( out==(MAT *)NULL || out->m != mat1->m || out->n != mat1->n ) + out = m_resize(out,mat1->m,mat1->n); + m = mat1->m; n = mat1->n; + for ( i=0; ime[i],mat2->me[i],out->me[i],(int)n); + /************************************************** + for ( j=0; jme[i][j] = mat1->me[i][j]+mat2->me[i][j]; + **************************************************/ + } + + return (out); +} + +/* m_sub -- matrix subtraction -- may be in-situ */ +MAT *m_sub(mat1,mat2,out) +MAT *mat1,*mat2,*out; +{ + u_int m,n,i; + + if ( mat1==(MAT *)NULL || mat2==(MAT *)NULL ) + error(E_NULL,"m_sub"); + if ( mat1->m != mat2->m || mat1->n != mat2->n ) + error(E_SIZES,"m_sub"); + if ( out==(MAT *)NULL || out->m != mat1->m || out->n != mat1->n ) + out = m_resize(out,mat1->m,mat1->n); + m = mat1->m; n = mat1->n; + for ( i=0; ime[i],mat2->me[i],out->me[i],(int)n); + /************************************************** + for ( j=0; jme[i][j] = mat1->me[i][j]-mat2->me[i][j]; + **************************************************/ + } + + return (out); +} + +/* m_mlt -- matrix-matrix multiplication */ +MAT *m_mlt(A,B,OUT) +MAT *A,*B,*OUT; +{ + u_int i, /* j, */ k, m, n, p; + Real **A_v, **B_v /*, *B_row, *OUT_row, sum, tmp */; + + if ( A==(MAT *)NULL || B==(MAT *)NULL ) + error(E_NULL,"m_mlt"); + if ( A->n != B->m ) + error(E_SIZES,"m_mlt"); + if ( A == OUT || B == OUT ) + error(E_INSITU,"m_mlt"); + m = A->m; n = A->n; p = B->n; + A_v = A->me; B_v = B->me; + + if ( OUT==(MAT *)NULL || OUT->m != A->m || OUT->n != B->n ) + OUT = m_resize(OUT,A->m,B->n); + +/**************************************************************** + for ( i=0; ime[i][j] = sum; + } +****************************************************************/ + m_zero(OUT); + for ( i=0; ime[i],B_v[k],A_v[i][k],(int)p); + /************************************************** + B_row = B_v[k]; OUT_row = OUT->me[i]; + for ( j=0; jn != B->n ) + error(E_SIZES,"mmtr_mlt"); + if ( ! OUT || OUT->m != A->m || OUT->n != B->m ) + OUT = m_resize(OUT,A->m,B->m); + + limit = A->n; + for ( i = 0; i < A->m; i++ ) + for ( j = 0; j < B->m; j++ ) + { + OUT->me[i][j] = __ip__(A->me[i],B->me[j],(int)limit); + /************************************************** + sum = 0.0; + A_row = A->me[i]; + B_row = B->me[j]; + for ( k = 0; k < limit; k++ ) + sum += (*A_row++)*(*B_row++); + OUT->me[i][j] = sum; + **************************************************/ + } + + return OUT; +} + +/* mtrm_mlt -- matrix transposed-matrix multiplication + -- A^T.B is returned, result stored in OUT */ +MAT *mtrm_mlt(A,B,OUT) +MAT *A, *B, *OUT; +{ + int i, k, limit; + /* Real *B_row, *OUT_row, multiplier; */ + + if ( ! A || ! B ) + error(E_NULL,"mmtr_mlt"); + if ( A == OUT || B == OUT ) + error(E_INSITU,"mtrm_mlt"); + if ( A->m != B->m ) + error(E_SIZES,"mmtr_mlt"); + if ( ! OUT || OUT->m != A->n || OUT->n != B->n ) + OUT = m_resize(OUT,A->n,B->n); + + limit = B->n; + m_zero(OUT); + for ( k = 0; k < A->m; k++ ) + for ( i = 0; i < A->n; i++ ) + { + if ( A->me[k][i] != 0.0 ) + __mltadd__(OUT->me[i],B->me[k],A->me[k][i],(int)limit); + /************************************************** + multiplier = A->me[k][i]; + OUT_row = OUT->me[i]; + B_row = B->me[k]; + for ( j = 0; j < limit; j++ ) + *(OUT_row++) += multiplier*(*B_row++); + **************************************************/ + } + + return OUT; +} + +/* mv_mlt -- matrix-vector multiplication + -- Note: b is treated as a column vector */ +VEC *mv_mlt(A,b,out) +MAT *A; +VEC *b,*out; +{ + u_int i, m, n; + Real **A_v, *b_v /*, *A_row */; + /* register Real sum; */ + + if ( A==(MAT *)NULL || b==(VEC *)NULL ) + error(E_NULL,"mv_mlt"); + if ( A->n != b->dim ) + error(E_SIZES,"mv_mlt"); + if ( b == out ) + error(E_INSITU,"mv_mlt"); + if ( out == (VEC *)NULL || out->dim != A->m ) + out = v_resize(out,A->m); + + m = A->m; n = A->n; + A_v = A->me; b_v = b->ve; + for ( i=0; ive[i] = __ip__(A_v[i],b_v,(int)n); + /************************************************** + A_row = A_v[i]; b_v = b->ve; + for ( j=0; jve[i] = sum; + **************************************************/ + } + + return out; +} + +/* sm_mlt -- scalar-matrix multiply -- may be in-situ */ +MAT *sm_mlt(scalar,matrix,out) +double scalar; +MAT *matrix,*out; +{ + u_int m,n,i; + + if ( matrix==(MAT *)NULL ) + error(E_NULL,"sm_mlt"); + if ( out==(MAT *)NULL || out->m != matrix->m || out->n != matrix->n ) + out = m_resize(out,matrix->m,matrix->n); + m = matrix->m; n = matrix->n; + for ( i=0; ime[i],(double)scalar,out->me[i],(int)n); + /************************************************** + for ( j=0; jme[i][j] = scalar*matrix->me[i][j]; + **************************************************/ + return (out); +} + +/* vm_mlt -- vector-matrix multiplication + -- Note: b is treated as a row vector */ +VEC *vm_mlt(A,b,out) +MAT *A; +VEC *b,*out; +{ + u_int j,m,n; + /* Real sum,**A_v,*b_v; */ + + if ( A==(MAT *)NULL || b==(VEC *)NULL ) + error(E_NULL,"vm_mlt"); + if ( A->m != b->dim ) + error(E_SIZES,"vm_mlt"); + if ( b == out ) + error(E_INSITU,"vm_mlt"); + if ( out == (VEC *)NULL || out->dim != A->n ) + out = v_resize(out,A->n); + + m = A->m; n = A->n; + + v_zero(out); + for ( j = 0; j < m; j++ ) + if ( b->ve[j] != 0.0 ) + __mltadd__(out->ve,A->me[j],b->ve[j],(int)n); + /************************************************** + A_v = A->me; b_v = b->ve; + for ( j=0; jve[j] = sum; + } + **************************************************/ + + return out; +} + +/* m_transp -- transpose matrix */ +MAT *m_transp(in,out) +MAT *in, *out; +{ + int i, j; + int in_situ; + Real tmp; + + if ( in == (MAT *)NULL ) + error(E_NULL,"m_transp"); + if ( in == out && in->n != in->m ) + error(E_INSITU2,"m_transp"); + in_situ = ( in == out ); + if ( out == (MAT *)NULL || out->m != in->n || out->n != in->m ) + out = m_resize(out,in->n,in->m); + + if ( ! in_situ ) + for ( i = 0; i < in->m; i++ ) + for ( j = 0; j < in->n; j++ ) + out->me[j][i] = in->me[i][j]; + else + for ( i = 1; i < in->m; i++ ) + for ( j = 0; j < i; j++ ) + { tmp = in->me[i][j]; + in->me[i][j] = in->me[j][i]; + in->me[j][i] = tmp; + } + + return out; +} + +/* swap_rows -- swaps rows i and j of matrix A upto column lim */ +MAT *swap_rows(A,i,j,lo,hi) +MAT *A; +int i, j, lo, hi; +{ + int k; + Real **A_me, tmp; + + if ( ! A ) + error(E_NULL,"swap_rows"); + if ( i < 0 || j < 0 || i >= A->m || j >= A->m ) + error(E_SIZES,"swap_rows"); + lo = max(0,lo); + hi = min(hi,A->n-1); + A_me = A->me; + + for ( k = lo; k <= hi; k++ ) + { + tmp = A_me[k][i]; + A_me[k][i] = A_me[k][j]; + A_me[k][j] = tmp; + } + return A; +} + +/* swap_cols -- swap columns i and j of matrix A upto row lim */ +MAT *swap_cols(A,i,j,lo,hi) +MAT *A; +int i, j, lo, hi; +{ + int k; + Real **A_me, tmp; + + if ( ! A ) + error(E_NULL,"swap_cols"); + if ( i < 0 || j < 0 || i >= A->n || j >= A->n ) + error(E_SIZES,"swap_cols"); + lo = max(0,lo); + hi = min(hi,A->m-1); + A_me = A->me; + + for ( k = lo; k <= hi; k++ ) + { + tmp = A_me[i][k]; + A_me[i][k] = A_me[j][k]; + A_me[j][k] = tmp; + } + return A; +} + +/* ms_mltadd -- matrix-scalar multiply and add + -- may be in situ + -- returns out == A1 + s*A2 */ +MAT *ms_mltadd(A1,A2,s,out) +MAT *A1, *A2, *out; +double s; +{ + /* register Real *A1_e, *A2_e, *out_e; */ + /* register int j; */ + int i, m, n; + + if ( ! A1 || ! A2 ) + error(E_NULL,"ms_mltadd"); + if ( A1->m != A2->m || A1->n != A2->n ) + error(E_SIZES,"ms_mltadd"); + + if ( s == 0.0 ) + return m_copy(A1,out); + if ( s == 1.0 ) + return m_add(A1,A2,out); + + tracecatch(out = m_copy(A1,out),"ms_mltadd"); + + m = A1->m; n = A1->n; + for ( i = 0; i < m; i++ ) + { + __mltadd__(out->me[i],A2->me[i],s,(int)n); + /************************************************** + A1_e = A1->me[i]; + A2_e = A2->me[i]; + out_e = out->me[i]; + for ( j = 0; j < n; j++ ) + out_e[j] = A1_e[j] + s*A2_e[j]; + **************************************************/ + } + + return out; +} + +/* mv_mltadd -- matrix-vector multiply and add + -- may not be in situ + -- returns out == v1 + alpha*A*v2 */ +VEC *mv_mltadd(v1,v2,A,alpha,out) +VEC *v1, *v2, *out; +MAT *A; +double alpha; +{ + /* register int j; */ + int i, m, n; + Real *v2_ve, *out_ve; + + if ( ! v1 || ! v2 || ! A ) + error(E_NULL,"mv_mltadd"); + if ( out == v2 ) + error(E_INSITU,"mv_mltadd"); + if ( v1->dim != A->m || v2->dim != A-> n ) + error(E_SIZES,"mv_mltadd"); + + tracecatch(out = v_copy(v1,out),"mv_mltadd"); + + v2_ve = v2->ve; out_ve = out->ve; + m = A->m; n = A->n; + + if ( alpha == 0.0 ) + return out; + + for ( i = 0; i < m; i++ ) + { + out_ve[i] += alpha*__ip__(A->me[i],v2_ve,(int)n); + /************************************************** + A_e = A->me[i]; + sum = 0.0; + for ( j = 0; j < n; j++ ) + sum += A_e[j]*v2_ve[j]; + out_ve[i] = v1->ve[i] + alpha*sum; + **************************************************/ + } + + return out; +} + +/* vm_mltadd -- vector-matrix multiply and add + -- may not be in situ + -- returns out' == v1' + v2'*A */ +VEC *vm_mltadd(v1,v2,A,alpha,out) +VEC *v1, *v2, *out; +MAT *A; +double alpha; +{ + int /* i, */ j, m, n; + Real tmp, /* *A_e, */ *out_ve; + + if ( ! v1 || ! v2 || ! A ) + error(E_NULL,"vm_mltadd"); + if ( v2 == out ) + error(E_INSITU,"vm_mltadd"); + if ( v1->dim != A->n || A->m != v2->dim ) + error(E_SIZES,"vm_mltadd"); + + tracecatch(out = v_copy(v1,out),"vm_mltadd"); + + out_ve = out->ve; m = A->m; n = A->n; + for ( j = 0; j < m; j++ ) + { + tmp = v2->ve[j]*alpha; + if ( tmp != 0.0 ) + __mltadd__(out_ve,A->me[j],tmp,(int)n); + /************************************************** + A_e = A->me[j]; + for ( i = 0; i < n; i++ ) + out_ve[i] += A_e[i]*tmp; + **************************************************/ + } + + return out; +} + diff --git a/meschach/matrix.h b/meschach/matrix.h new file mode 100644 index 0000000..c684c3b --- /dev/null +++ b/meschach/matrix.h @@ -0,0 +1,530 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Type definitions for general purpose maths package +*/ + +#ifndef MATRIXH + +/* RCS id: $Id: matrix.h,v 1.1 2001/03/01 17:18:47 rfranke Exp $ */ + +#define MATRIXH + +#include "machine.h" +#include "m_err.h" +#include "meminfo.h" + +/* unsigned integer type */ +#ifndef U_INT_DEF +typedef unsigned int u_int; +#define U_INT_DEF +#endif + +/* vector definition */ +typedef struct VEC { + u_int dim, max_dim; + Real *ve; + } VEC; + +/* matrix definition */ +typedef struct MAT { + u_int m, n; + u_int max_m, max_n, max_size; + Real **me,*base; /* base is base of alloc'd mem */ + } MAT; + +/* band matrix definition */ +typedef struct BAND { + MAT *mat; /* matrix */ + int lb,ub; /* lower and upper bandwidth */ + } BAND; + + +/* permutation definition */ +typedef struct PERM { + u_int size, max_size, *pe; + } PERM; + +/* integer vector definition */ +typedef struct IVEC { + u_int dim, max_dim; + int *ive; + } IVEC; + +MESCH__BEGIN_DECLS + +/* Meschach version routine */ +void m_version MESCH__P((void)); + +#ifndef ANSI_C +/* allocate one object of given type */ +#define NEW(type) ((type *)calloc(1,sizeof(type))) + +/* allocate num objects of given type */ +#define NEW_A(num,type) ((type *)calloc((unsigned)(num),sizeof(type))) + +/* re-allocate arry to have num objects of the given type */ +#define RENEW(var,num,type) \ + ((var)=(type *)((var) ? \ + realloc((char *)(var),(unsigned)(num)*sizeof(type)) : \ + calloc((unsigned)(num),sizeof(type)))) + +#define MEMCOPY(from,to,n_items,type) \ + MEM_COPY((char *)(from),(char *)(to),(unsigned)(n_items)*sizeof(type)) + +#else +/* allocate one object of given type */ +#define NEW(type) ((type *)calloc((size_t)1,(size_t)sizeof(type))) + +/* allocate num objects of given type */ +#define NEW_A(num,type) ((type *)calloc((size_t)(num),(size_t)sizeof(type))) + +/* re-allocate arry to have num objects of the given type */ +#define RENEW(var,num,type) \ + ((var)=(type *)((var) ? \ + realloc((char *)(var),(size_t)((num)*sizeof(type))) : \ + calloc((size_t)(num),(size_t)sizeof(type)))) + +#define MEMCOPY(from,to,n_items,type) \ + MEM_COPY((char *)(from),(char *)(to),(unsigned)(n_items)*sizeof(type)) + +#endif + +/* type independent min and max operations */ +#ifndef max +#define max(a,b) ((a) > (b) ? (a) : (b)) +#endif +#ifndef min +#define min(a,b) ((a) > (b) ? (b) : (a)) +#endif + + +#undef TRUE +#define TRUE 1 +#undef FALSE +#define FALSE 0 + + +/* for input routines */ +#define MAXLINE 81 + + +/* Dynamic memory allocation */ + +/* Should use M_FREE/V_FREE/PX_FREE in programs instead of m/v/px_free() + as this is considerably safer -- also provides a simple type check ! */ + +/* get/resize vector to given dimension */ +VEC *v_get MESCH__P((int)), *v_resize MESCH__P((VEC *, int)); + +/* get/resize matrix to be m x n */ +MAT *m_get MESCH__P((int, int)), *m_resize MESCH__P((MAT *, int, int)); + +/* get/resize permutation to have the given size */ +PERM *px_get MESCH__P((int)), *px_resize MESCH__P((PERM *, int)); + +/* get/resize an integer vector to given dimension */ +IVEC *iv_get MESCH__P((int)), *iv_resize MESCH__P((IVEC *, int)); + +/* get/resize a band matrix to given dimension */ +BAND *bd_get MESCH__P((int, int, int)); +BAND *bd_resize MESCH__P((BAND *, int, int, int)); + +/* free (de-allocate) (band) matrices, vectors, permutations and + integer vectors */ +int iv_free MESCH__P((IVEC *)); +int m_free MESCH__P((MAT *)), v_free MESCH__P((VEC *)), px_free MESCH__P((PERM *)); +int bd_free MESCH__P((BAND *)); + + +/* MACROS */ + +/* macros that also check types and sets pointers to NULL */ +#define M_FREE(mat) ( m_free(mat), (mat)=(MAT *)NULL ) +#define V_FREE(vec) ( v_free(vec), (vec)=(VEC *)NULL ) +#define PX_FREE(px) ( px_free(px), (px)=(PERM *)NULL ) +#define IV_FREE(iv) ( iv_free(iv), (iv)=(IVEC *)NULL ) + +#define MAXDIM M_MAX_INT + + +/* Entry level access to data structures */ +#ifdef DEBUG + +/* returns x[i] */ +#define v_entry(x,i) (((i) < 0 || (i) >= (x)->dim) ? \ + error(E_BOUNDS,"v_entry"), 0.0 : (x)->ve[i] ) + +/* x[i] <- val */ +#define v_set_val(x,i,val) ((x)->ve[i] = ((i) < 0 || (i) >= (x)->dim) ? \ + error(E_BOUNDS,"v_set_val"), 0.0 : (val)) + +/* x[i] <- x[i] + val */ +#define v_add_val(x,i,val) ((x)->ve[i] += ((i) < 0 || (i) >= (x)->dim) ? \ + error(E_BOUNDS,"v_set_val"), 0.0 : (val)) + +/* x[i] <- x[i] - val */ +#define v_sub_val(x,i,val) ((x)->ve[i] -= ((i) < 0 || (i) >= (x)->dim) ? \ + error(E_BOUNDS,"v_set_val"), 0.0 : (val)) + +/* returns A[i][j] */ +#define m_entry(A,i,j) (((i) < 0 || (i) >= (A)->m || \ + (j) < 0 || (j) >= (A)->n) ? \ + error(E_BOUNDS,"m_entry"), 0.0 : (A)->me[i][j] ) + +/* A[i][j] <- val */ +#define m_set_val(A,i,j,val) ((A)->me[i][j] = ((i) < 0 || (i) >= (A)->m || \ + (j) < 0 || (j) >= (A)->n) ? \ + error(E_BOUNDS,"m_set_val"), 0.0 : (val) ) + +/* A[i][j] <- A[i][j] + val */ +#define m_add_val(A,i,j,val) ((A)->me[i][j] += ((i) < 0 || (i) >= (A)->m || \ + (j) < 0 || (j) >= (A)->n) ? \ + error(E_BOUNDS,"m_set_val"), 0.0 : (val) ) + +/* A[i][j] <- A[i][j] - val */ +#define m_sub_val(A,i,j,val) ((A)->me[i][j] -= ((i) < 0 || (i) >= (A)->m || \ + (j) < 0 || (j) >= (A)->n) ? \ + error(E_BOUNDS,"m_set_val"), 0.0 : (val) ) +#else + +/* returns x[i] */ +#define v_entry(x,i) ((x)->ve[i]) + +/* x[i] <- val */ +#define v_set_val(x,i,val) ((x)->ve[i] = (val)) + +/* x[i] <- x[i] + val */ +#define v_add_val(x,i,val) ((x)->ve[i] += (val)) + + /* x[i] <- x[i] - val */ +#define v_sub_val(x,i,val) ((x)->ve[i] -= (val)) + +/* returns A[i][j] */ +#define m_entry(A,i,j) ((A)->me[i][j]) + +/* A[i][j] <- val */ +#define m_set_val(A,i,j,val) ((A)->me[i][j] = (val) ) + +/* A[i][j] <- A[i][j] + val */ +#define m_add_val(A,i,j,val) ((A)->me[i][j] += (val) ) + +/* A[i][j] <- A[i][j] - val */ +#define m_sub_val(A,i,j,val) ((A)->me[i][j] -= (val) ) + +#endif + + +/* I/O routines */ + +/* print x on file fp */ +void v_foutput MESCH__P((FILE *fp, const VEC *x)); + +/* print A on file fp */ +void m_foutput MESCH__P((FILE *fp, const MAT *A)); + +/* print px on file fp */ +void px_foutput MESCH__P((FILE *fp, const PERM *px)); + +/* print ix on file fp */ +void iv_foutput MESCH__P((FILE *fp, const IVEC *ix)); + +/* Note: if out is NULL, then returned object is newly allocated; + Also: if out is not NULL, then that size is assumed */ + +/* read in vector from fp */ +VEC *v_finput MESCH__P((FILE *fp, VEC *out)); + +/* read in matrix from fp */ +MAT *m_finput MESCH__P((FILE *fp, MAT *out)); + +/* read in permutation from fp */ +PERM *px_finput MESCH__P((FILE *fp, PERM *out)); + +/* read in int vector from fp */ +IVEC *iv_finput MESCH__P((FILE *fp, IVEC *out)); + + +/* fy_or_n -- yes-or-no to question in string s + -- question written to stderr, input from fp + -- if fp is NOT a tty then return y_n_dflt */ +int fy_or_n MESCH__P((FILE *fp, const char *s)); + +/* yn_dflt -- sets the value of y_n_dflt to val */ +int yn_dflt MESCH__P((int val)); + +/* fin_int -- return integer read from file/stream fp + -- prompt s on stderr if fp is a tty + -- check that x lies between low and high: re-prompt if + fp is a tty, error exit otherwise + -- ignore check if low > high */ +int fin_int MESCH__P((FILE *fp, const char *s, int low, int high)); + +/* fin_double -- return double read from file/stream fp + -- prompt s on stderr if fp is a tty + -- check that x lies between low and high: re-prompt if + fp is a tty, error exit otherwise + -- ignore check if low > high */ +double fin_double MESCH__P((FILE *fp, const char *s, double low, double high)); + +/* it skips white spaces and strings of the form #....\n + Here .... is a comment string */ +int skipjunk MESCH__P((FILE *fp)); + + +/* MACROS */ + +/* macros to use stdout and stdin instead of explicit fp */ +#define v_output(vec) v_foutput(stdout,vec) +#define v_input(vec) v_finput(stdin,vec) +#define m_output(mat) m_foutput(stdout,mat) +#define m_input(mat) m_finput(stdin,mat) +#define px_output(px) px_foutput(stdout,px) +#define px_input(px) px_finput(stdin,px) +#define iv_output(iv) iv_foutput(stdout,iv) +#define iv_input(iv) iv_finput(stdin,iv) + +/* general purpose input routine; skips comments # ... \n */ +#define finput(fp,prompt,fmt,var) \ + ( ( isatty(fileno(fp)) ? fprintf(stderr,prompt) : skipjunk(fp) ), \ + fscanf(fp,fmt,var) ) +#define input(prompt,fmt,var) finput(stdin,prompt,fmt,var) +#define fprompter(fp,prompt) \ + ( isatty(fileno(fp)) ? fprintf(stderr,prompt) : skipjunk(fp) ) +#define prompter(prompt) fprompter(stdin,prompt) +#define y_or_n(s) fy_or_n(stdin,s) +#define in_int(s,lo,hi) fin_int(stdin,s,lo,hi) +#define in_double(s,lo,hi) fin_double(stdin,s,lo,hi) + +/* Copying routines */ + +/* copy in to out starting at out[i0][j0] */ +MAT *_m_copy MESCH__P((const MAT *in, MAT *out, u_int i0, u_int j0)); +MAT * m_move MESCH__P((const MAT *in, int, int, int, int, MAT *out, int, int)); +MAT *vm_move MESCH__P((const VEC *in, int, MAT *out, int, int, int, int)); + +/* copy in to out starting at out[i0] */ +VEC *_v_copy MESCH__P((const VEC *in, VEC *out, u_int i0)); +VEC * v_move MESCH__P((const VEC *in, int, int, VEC *out, int)); +VEC *mv_move MESCH__P((const MAT *in, int, int, int, int, VEC *out, int)); +PERM *px_copy MESCH__P((const PERM *in, PERM *out)); +IVEC *iv_copy MESCH__P((const IVEC *in, IVEC *out)); +IVEC *iv_move MESCH__P((const IVEC *in, int, int, IVEC *out, int)); +BAND *bd_copy MESCH__P((const BAND *in, BAND *out)); + +/* MACROS */ +#define m_copy(in,out) _m_copy(in,out,0,0) +#define v_copy(in,out) _v_copy(in,out,0) + + +/* Initialisation routines -- to be zero, ones, random or identity */ +VEC *v_zero MESCH__P((VEC *)); +VEC *v_rand MESCH__P((VEC *)); +VEC *v_ones MESCH__P((VEC *)); +MAT *m_zero MESCH__P((MAT *)); +MAT *m_ident MESCH__P((MAT *)); +MAT *m_rand MESCH__P((MAT *)); +MAT *m_ones MESCH__P((MAT *)); +PERM *px_ident MESCH__P((PERM *)); +IVEC *iv_zero MESCH__P((IVEC *)); + +/* Basic vector operations */ + +VEC *sv_mlt MESCH__P((double, const VEC *, VEC *)); +VEC *mv_mlt MESCH__P((const MAT *, const VEC *, VEC *)); +VEC *vm_mlt MESCH__P((const MAT *, const VEC *,VEC *)); +VEC *v_add MESCH__P((const VEC *, const VEC *, VEC *)); +VEC *v_sub MESCH__P((const VEC *, const VEC *, VEC *)); +VEC *px_vec MESCH__P((const PERM *, const VEC *, VEC *)); +VEC *pxinv_vec MESCH__P((const PERM *,const VEC *,VEC *)); +VEC *v_mltadd MESCH__P((const VEC *, const VEC *, double, VEC *)); + +#ifdef HAVE_PROTOTYPES_IN_STRUCT +VEC *v_map MESCH__P((double (*f) MESCH__P((double)), const VEC *, VEC *)); +VEC *_v_map MESCH__P((double (*f) MESCH__P((void *, double)), void *, const VEC *, + VEC *)); +#else +VEC *v_map MESCH__P((double (*f)(), const VEC *, VEC *)); +VEC *_v_map MESCH__P((double (*f)(), void *, const VEC *, VEC *)); +#endif + +VEC *v_lincomb MESCH__P((int, const VEC *[], const Real *, VEC *)); +VEC *v_linlist MESCH__P((VEC *out, const VEC *v1, double a1, ...)); + +double v_min MESCH__P((const VEC *, int *)); +double v_max MESCH__P((const VEC *, int *)); +double v_sum MESCH__P((const VEC *)); + +/* Hadamard product: out[i] <- x[i].y[i] */ +VEC *v_star MESCH__P((const VEC *, const VEC *, VEC *)); +VEC *v_slash MESCH__P((const VEC *, const VEC *, VEC *)); + +/* sorts x, and sets order so that sorted x[i] = x[order[i]] */ +VEC *v_sort MESCH__P((VEC *, PERM *)); + +/* returns inner product starting at component i0 */ +double _in_prod MESCH__P((const VEC *x, const VEC *y, u_int i0)); + +/* returns sum_{i=0}^{len-1} x[i].y[i] */ +double __ip__ MESCH__P((const Real *, const Real *, int)); + +/* see v_mltadd(), v_add(), v_sub() and v_zero() */ +void __mltadd__ MESCH__P((const Real *, Real *, double, int)); +void __add__ MESCH__P((const Real *, const Real *, Real *, int)); +void __sub__ MESCH__P((const Real *, const Real *, Real *, int)); +void __smlt__ MESCH__P((const Real *, double, Real *, int)); +void __zero__ MESCH__P((Real *,int)); + + +/* MACRO */ +/* usual way of computing the inner product */ +#define in_prod(a,b) _in_prod(a,b,0) + +/* Norms */ + +/* scaled vector norms -- scale == NULL implies unscaled */ +double _v_norm1 MESCH__P((const VEC *x, const VEC *scale)); +double _v_norm2 MESCH__P((const VEC *x, const VEC *scale)); +double _v_norm_inf MESCH__P((const VEC *x, const VEC *scale)); + +/* unscaled matrix norms */ +double m_norm1 MESCH__P((const MAT *A)); +double m_norm_inf MESCH__P((const MAT *A)); +double m_norm_frob MESCH__P((const MAT *A)); + +/* MACROS */ +/* unscaled vector norms */ +#define v_norm1(x) _v_norm1(x,VNULL) +#define v_norm2(x) _v_norm2(x,VNULL) +#define v_norm_inf(x) _v_norm_inf(x,VNULL) + +/* Basic matrix operations */ +MAT *sm_mlt MESCH__P((double s, const MAT *A, MAT *out)); +MAT *m_mlt MESCH__P((const MAT *A, const MAT *B, MAT *out)); +MAT *mmtr_mlt MESCH__P((const MAT *A, const MAT *B, MAT *out)); +MAT *mtrm_mlt MESCH__P((const MAT *A, const MAT *B, MAT *out)); +MAT *m_add MESCH__P((const MAT *A, const MAT *B, MAT *out)); +MAT *m_sub MESCH__P((const MAT *A, const MAT *B, MAT *out)); +MAT *sub_mat MESCH__P((const MAT *A, u_int, u_int, u_int, u_int, MAT *out)); +MAT *m_transp MESCH__P((const MAT *A, MAT *out)); +MAT *ms_mltadd MESCH__P((const MAT *A, const MAT *B, double s, MAT *out)); + +BAND *bd_transp MESCH__P((const BAND *in, BAND *out)); + +MAT *px_rows MESCH__P((const PERM *px, const MAT *A, MAT *out)); +MAT *px_cols MESCH__P((const PERM *px, const MAT *A, MAT *out)); +MAT *swap_rows MESCH__P((MAT *, int, int, int, int)); +MAT *swap_cols MESCH__P((MAT *, int, int, int, int)); +MAT *_set_col MESCH__P((MAT *A, u_int i, const VEC *out, u_int j0)); +MAT *_set_row MESCH__P((MAT *A, u_int j, const VEC *out, u_int i0)); + +VEC *get_row MESCH__P((const MAT *, u_int, VEC *)); +VEC *get_col MESCH__P((const MAT *, u_int, VEC *)); +VEC *sub_vec MESCH__P((const VEC *, int, int, VEC *)); +VEC *mv_mltadd MESCH__P((const VEC *x, const VEC *y, const MAT *A, double s, + VEC *out)); +VEC *vm_mltadd MESCH__P((const VEC *x, const VEC *y, const MAT *A, double s, + VEC *out)); + + +/* MACROS */ +/* row i of A <- vec */ +#define set_row(mat,row,vec) _set_row(mat,row,vec,0) +/* col j of A <- vec */ +#define set_col(mat,col,vec) _set_col(mat,col,vec,0) + + +/* Basic permutation operations */ +PERM *px_mlt MESCH__P((const PERM *px1, const PERM *px2, PERM *out)); +PERM *px_inv MESCH__P((const PERM *px, PERM *out)); +PERM *px_transp MESCH__P((PERM *px, u_int i, u_int j)); + +/* returns sign(px) = +1 if px product of even # transpositions + -1 if ps product of odd # transpositions */ +int px_sign MESCH__P((const PERM *)); + + +/* Basic integer vector operations */ +IVEC *iv_add MESCH__P((const IVEC *ix, const IVEC *iy, IVEC *out)); +IVEC *iv_sub MESCH__P((const IVEC *ix, const IVEC *iy, IVEC *out)); +IVEC *iv_sort MESCH__P((IVEC *ix, PERM *order)); + + +/* miscellaneous functions */ + +double square MESCH__P((double x)); +/*double cube MESCH__P((double x)); */ +double mrand MESCH__P((void)); +void smrand MESCH__P((int seed)); +void mrandlist MESCH__P((Real *x, int len)); + +void m_dump MESCH__P((FILE *fp, const MAT *a)); +void px_dump MESCH__P((FILE *fp, const PERM *px)); +void v_dump MESCH__P((FILE *fp, const VEC *x)); +void iv_dump MESCH__P((FILE *fp, const IVEC *ix)); + +MAT *band2mat MESCH__P((const BAND *bA, MAT *A)); +BAND *mat2band MESCH__P((const MAT *A, int lb, int ub, BAND *bA)); + + +/* miscellaneous constants */ +#define VNULL ((VEC *)NULL) +#define MNULL ((MAT *)NULL) +#define PNULL ((PERM *)NULL) +#define IVNULL ((IVEC *)NULL) +#define BDNULL ((BAND *)NULL) + + +/* varying number of arguments */ + +#ifdef ANSI_C +#include +#elif VARARGS +/* old varargs is used */ +#include +#endif + +int v_get_vars MESCH__P((int dim, ...)); +int iv_get_vars MESCH__P((int dim, ...)); +int m_get_vars MESCH__P((int m,int n, ...)); +int px_get_vars MESCH__P((int dim, ...)); + +int v_resize_vars MESCH__P((int new_dim, ...)); +int iv_resize_vars MESCH__P((int new_dim, ...)); +int m_resize_vars MESCH__P((int m,int n, ...)); +int px_resize_vars MESCH__P((int new_dim, ...)); + +int v_free_vars MESCH__P((VEC **, ...)); +int iv_free_vars MESCH__P((IVEC **, ...)); +int px_free_vars MESCH__P((PERM **, ...)); +int m_free_vars MESCH__P((MAT **, ...)); + +MESCH__END_DECLS + +#endif + + diff --git a/meschach/matrix2.h b/meschach/matrix2.h new file mode 100644 index 0000000..f8114c6 --- /dev/null +++ b/meschach/matrix2.h @@ -0,0 +1,229 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Header file for ``matrix2.a'' library file +*/ + + +#ifndef MATRIX2H +#define MATRIX2H + +#include "matrix.h" + +/* Unless otherwise specified, factorisation routines overwrite the + matrix that is being factorised */ + +#ifndef ANSI_C + +extern MAT *BKPfactor(), *CHfactor(), *LUfactor(), *QRfactor(), + *QRCPfactor(), *LDLfactor(), *Hfactor(), *MCHfactor(), + *m_inverse(); +extern double LUcondest(), QRcondest(); +extern MAT *makeQ(), *makeR(), *makeHQ(), *makeH(); +extern MAT *LDLupdate(), *QRupdate(); + +extern VEC *BKPsolve(), *CHsolve(), *LUsolve(), *_Qsolve(), *QRsolve(), + *LDLsolve(), *Usolve(), *Lsolve(), *Dsolve(), *LTsolve(), + *UTsolve(), *LUTsolve(), *QRCPsolve(); + +extern BAND *bdLUfactor(), *bdLDLfactor(); +extern VEC *bdLUsolve(), *bdLDLsolve(); + +extern VEC *hhvec(); +extern VEC *hhtrvec(); +extern MAT *hhtrrows(); +extern MAT *hhtrcols(); + +extern void givens(); +extern VEC *rot_vec(); /* in situ */ +extern MAT *rot_rows(); /* in situ */ +extern MAT *rot_cols(); /* in situ */ + + +/* eigenvalue routines */ +extern VEC *trieig(), *symmeig(); +extern MAT *schur(); +extern void schur_evals(); +extern MAT *schur_vecs(); + +/* singular value decomposition */ +extern VEC *bisvd(), *svd(); + +/* matrix powers and exponent */ +MAT *_m_pow(); +MAT *m_pow(); +MAT *m_exp(), *_m_exp(); +MAT *m_poly(); + +/* FFT */ +void fft(); +void ifft(); + + +#else + + /* forms Bunch-Kaufman-Parlett factorisation for + symmetric indefinite matrices */ +extern MAT *BKPfactor(MAT *A,PERM *pivot,PERM *blocks), + /* Cholesky factorisation of A + (symmetric, positive definite) */ + *CHfactor(MAT *A), + /* LU factorisation of A (with partial pivoting) */ + *LUfactor(MAT *A,PERM *pivot), + /* QR factorisation of A; need dim(diag) >= # rows of A */ + *QRfactor(MAT *A,VEC *diag), + /* QR factorisation of A with column pivoting */ + *QRCPfactor(MAT *A,VEC *diag,PERM *pivot), + /* L.D.L^T factorisation of A */ + *LDLfactor(MAT *A), + /* Hessenberg factorisation of A -- for schur() */ + *Hfactor(MAT *A,VEC *diag1,VEC *diag2), + /* modified Cholesky factorisation of A; + actually factors A+D, D diagonal with no + diagonal entry in the factor < sqrt(tol) */ + *MCHfactor(MAT *A,double tol), + *m_inverse(MAT *A,MAT *out); + + /* returns condition estimate for A after LUfactor() */ +extern double LUcondest(MAT *A,PERM *pivot), + /* returns condition estimate for Q after QRfactor() */ + QRcondest(MAT *A); + +/* Note: The make..() and ..update() routines assume that the factorisation + has already been carried out */ + + /* Qout is the "Q" (orthongonal) matrix from QR factorisation */ +extern MAT *makeQ(MAT *A,VEC *diag,MAT *Qout), + /* Rout is the "R" (upper triangular) matrix + from QR factorisation */ + *makeR(MAT *A,MAT *Rout), + /* Qout is orthogonal matrix in Hessenberg factorisation */ + *makeHQ(MAT *A,VEC *diag1,VEC *diag2,MAT *Qout), + /* Hout is the Hessenberg matrix in Hessenberg factorisation */ + *makeH(MAT *A,MAT *Hout); + + /* updates L.D.L^T factorisation for A <- A + alpha.u.u^T */ +extern MAT *LDLupdate(MAT *A,VEC *u,double alpha), + /* updates QR factorisation for QR <- Q.(R+u.v^T) + Note: we need explicit Q & R matrices, + from makeQ() and makeR() */ + *QRupdate(MAT *Q,MAT *R,VEC *u,VEC *v); + +/* Solve routines assume that the corresponding factorisation routine + has already been applied to the matrix along with auxiliary + objects (such as pivot permutations) + + These solve the system A.x = b, + except for LUTsolve and QRTsolve which solve the transposed system + A^T.x. = b. + If x is NULL on entry, then it is created. +*/ + +extern VEC *BKPsolve(MAT *A,PERM *pivot,PERM *blocks,VEC *b,VEC *x), + *CHsolve(MAT *A,VEC *b,VEC *x), + *LDLsolve(MAT *A,VEC *b,VEC *x), + *LUsolve(MAT *A,PERM *pivot,VEC *b,VEC *x), + *_Qsolve(MAT *A,VEC *,VEC *,VEC *, VEC *), + *QRsolve(MAT *A,VEC *,VEC *b,VEC *x), + *QRTsolve(MAT *A,VEC *,VEC *b,VEC *x), + + + /* Triangular equations solve routines; + U for upper triangular, L for lower traingular, D for diagonal + if diag_val == 0.0 use that values in the matrix */ + + *Usolve(MAT *A,VEC *b,VEC *x,double diag_val), + *Lsolve(MAT *A,VEC *b,VEC *x,double diag_val), + *Dsolve(MAT *A,VEC *b,VEC *x), + *LTsolve(MAT *A,VEC *b,VEC *x,double diag_val), + *UTsolve(MAT *A,VEC *b,VEC *x,double diag_val), + *LUTsolve(MAT *A,PERM *,VEC *,VEC *), + *QRCPsolve(MAT *QR,VEC *diag,PERM *pivot,VEC *b,VEC *x); + +extern BAND *bdLUfactor(BAND *A,PERM *pivot), + *bdLDLfactor(BAND *A); +extern VEC *bdLUsolve(BAND *A,PERM *pivot,VEC *b,VEC *x), + *bdLDLsolve(BAND *A,VEC *b,VEC *x); + + + +extern VEC *hhvec(VEC *,u_int,Real *,VEC *,Real *); +extern VEC *hhtrvec(VEC *,double,u_int,VEC *,VEC *); +extern MAT *hhtrrows(MAT *,u_int,u_int,VEC *,double); +extern MAT *hhtrcols(MAT *,u_int,u_int,VEC *,double); + +extern void givens(double,double,Real *,Real *); +extern VEC *rot_vec(VEC *,u_int,u_int,double,double,VEC *); /* in situ */ +extern MAT *rot_rows(MAT *,u_int,u_int,double,double,MAT *); /* in situ */ +extern MAT *rot_cols(MAT *,u_int,u_int,double,double,MAT *); /* in situ */ + + +/* eigenvalue routines */ + + /* compute eigenvalues of tridiagonal matrix + with diagonal entries a[i], super & sub diagonal entries + b[i]; eigenvectors stored in Q (if not NULL) */ +extern VEC *trieig(VEC *a,VEC *b,MAT *Q), + /* sets out to be vector of eigenvectors; eigenvectors + stored in Q (if not NULL). A is unchanged */ + *symmeig(MAT *A,MAT *Q,VEC *out); + + /* computes real Schur form = Q^T.A.Q */ +extern MAT *schur(MAT *A,MAT *Q); + /* computes real and imaginary parts of the eigenvalues + of A after schur() */ +extern void schur_evals(MAT *A,VEC *re_part,VEC *im_part); + /* computes real and imaginary parts of the eigenvectors + of A after schur() */ +extern MAT *schur_vecs(MAT *T,MAT *Q,MAT *X_re,MAT *X_im); + + +/* singular value decomposition */ + + /* computes singular values of bi-diagonal matrix with + diagonal entries a[i] and superdiagonal entries b[i]; + singular vectors stored in U and V (if not NULL) */ +VEC *bisvd(VEC *a,VEC *b,MAT *U,MAT *V), + /* sets out to be vector of singular values; + singular vectors stored in U and V */ + *svd(MAT *A,MAT *U,MAT *V,VEC *out); + +/* matrix powers and exponent */ +MAT *_m_pow(MAT *,int,MAT *,MAT *); +MAT *m_pow(MAT *,int, MAT *); +MAT *m_exp(MAT *,double,MAT *); +MAT *_m_exp(MAT *,double,MAT *,int *,int *); +MAT *m_poly(MAT *,VEC *,MAT *); + +/* FFT */ +void fft(VEC *,VEC *); +void ifft(VEC *,VEC *); + +#endif + + +#endif diff --git a/meschach/matrixio.c b/meschach/matrixio.c new file mode 100644 index 0000000..4a08585 --- /dev/null +++ b/meschach/matrixio.c @@ -0,0 +1,522 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* 1.6 matrixio.c 11/25/87 */ + + +#include +#include +#include "matrix.h" + +static char rcsid[] = "$Id: matrixio.c,v 1.1 2001/03/01 17:18:48 rfranke Exp $"; + + +/* local variables */ +static char line[MAXLINE]; + + +/************************************************************************** + Input routines + **************************************************************************/ +/* skipjunk -- skips white spaces and strings of the form #....\n + Here .... is a comment string */ +int skipjunk(fp) +FILE *fp; +{ + int c; + + for ( ; ; ) /* forever do... */ + { + /* skip blanks */ + do + c = getc(fp); + while ( isspace(c) ); + + /* skip comments (if any) */ + if ( c == '#' ) + /* yes it is a comment (line) */ + while ( (c=getc(fp)) != '\n' ) + ; + else + { + ungetc(c,fp); + break; + } + } + return 0; +} + +MAT *m_finput(fp,a) +FILE *fp; +MAT *a; +{ + MAT *im_finput(),*bm_finput(); + + if ( isatty(fileno(fp)) ) + return im_finput(fp,a); + else + return bm_finput(fp,a); +} + +/* im_finput -- interactive input of matrix */ +MAT *im_finput(fp,mat) +FILE *fp; +MAT *mat; +{ + char c; + u_int i, j, m, n, dynamic; + /* dynamic set to TRUE if memory allocated here */ + + /* get matrix size */ + if ( mat != (MAT *)NULL && mat->mnm; n = mat->n; dynamic = FALSE; } + else + { + dynamic = TRUE; + do + { + fprintf(stderr,"Matrix: rows cols:"); + if ( fgets(line,MAXLINE,fp)==NULL ) + error(E_INPUT,"im_finput"); + } while ( sscanf(line,"%u%u",&m,&n)<2 || m>MAXDIM || n>MAXDIM ); + mat = m_get(m,n); + } + + /* input elements */ + for ( i=0; ime[i][j]); + if ( fgets(line,MAXLINE,fp)==NULL ) + error(E_INPUT,"im_finput"); + if ( (*line == 'b' || *line == 'B') && j > 0 ) + { j--; dynamic = FALSE; goto redo2; } + if ( (*line == 'f' || *line == 'F') && j < n-1 ) + { j++; dynamic = FALSE; goto redo2; } +#if REAL == DOUBLE + } while ( *line=='\0' || sscanf(line,"%lf",&mat->me[i][j])<1 ); +#elif REAL == FLOAT + } while ( *line=='\0' || sscanf(line,"%f",&mat->me[i][j])<1 ); +#endif + fprintf(stderr,"Continue: "); + fscanf(fp,"%c",&c); + if ( c == 'n' || c == 'N' ) + { dynamic = FALSE; goto redo; } + if ( (c == 'b' || c == 'B') /* && i > 0 */ ) + { if ( i > 0 ) + i--; + dynamic = FALSE; goto redo; + } + } + + return (mat); +} + +/* bm_finput -- batch-file input of matrix */ +MAT *bm_finput(fp,mat) +FILE *fp; +MAT *mat; +{ + u_int i,j,m,n,dummy; + int io_code; + + /* get dimension */ + skipjunk(fp); + if ((io_code=fscanf(fp," Matrix: %u by %u",&m,&n)) < 2 || + m>MAXDIM || n>MAXDIM ) + error(io_code==EOF ? E_EOF : E_FORMAT,"bm_finput"); + + /* allocate memory if necessary */ + if( mat==(MAT *)NULL || mat->m != m || mat->n !=n ) + mat = m_resize(mat,m,n); + + /* get entries */ + for ( i=0; ime[i][j])) < 1 ) +#elif REAL == FLOAT + if ((io_code=fscanf(fp,"%f",&mat->me[i][j])) < 1 ) +#endif + error(io_code==EOF ? 7 : 6,"bm_finput"); + } + + return (mat); +} + +PERM *px_finput(fp,px) +FILE *fp; +PERM *px; +{ + PERM *ipx_finput(),*bpx_finput(); + + if ( isatty(fileno(fp)) ) + return ipx_finput(fp,px); + else + return bpx_finput(fp,px); +} + + +/* ipx_finput -- interactive input of permutation */ +PERM *ipx_finput(fp,px) +FILE *fp; +PERM *px; +{ + u_int i,j,size,dynamic; /* dynamic set if memory allocated here */ + u_int entry,ok; + + /* get permutation size */ + if ( px!=(PERM *)NULL && px->sizesize; dynamic = FALSE; } + else + { + dynamic = TRUE; + do + { + fprintf(stderr,"Permutation: size: "); + if ( fgets(line,MAXLINE,fp)==NULL ) + error(E_INPUT,"ipx_finput"); + } while ( sscanf(line,"%u",&size)<1 || size>MAXDIM ); + px = px_get(size); + } + + /* get entries */ + i = 0; + while ( i%u new: ", + i,px->pe[i]); + if ( fgets(line,MAXLINE,fp)==NULL ) + error(E_INPUT,"ipx_finput"); + if ( (*line == 'b' || *line == 'B') && i > 0 ) + { i--; dynamic = FALSE; goto redo; } + } while ( *line=='\0' || sscanf(line,"%u",&entry) < 1 ); + /* check entry */ + ok = (entry < size); + for ( j=0; jpe[j]); + if ( ok ) + { + px->pe[i] = entry; + i++; + } + } + + return (px); +} + +/* bpx_finput -- batch-file input of permutation */ +PERM *bpx_finput(fp,px) +FILE *fp; +PERM *px; +{ + u_int i,j,size,entry,ok; + int io_code; + + /* get size of permutation */ + skipjunk(fp); + if ((io_code=fscanf(fp," Permutation: size:%u",&size)) < 1 || + size>MAXDIM ) + error(io_code==EOF ? 7 : 6,"bpx_finput"); + + /* allocate memory if necessary */ + if ( px==(PERM *)NULL || px->size %u",&entry)) < 1 ) + error(io_code==EOF ? 7 : 6,"bpx_finput"); + /* check entry */ + ok = (entry < size); + for ( j=0; jpe[j]); + if ( ok ) + { + px->pe[i] = entry; + i++; + } + else + error(E_BOUNDS,"bpx_finput"); + } + + return (px); +} + + +VEC *v_finput(fp,x) +FILE *fp; +VEC *x; +{ + VEC *ifin_vec(),*bfin_vec(); + + if ( isatty(fileno(fp)) ) + return ifin_vec(fp,x); + else + return bfin_vec(fp,x); +} + +/* ifin_vec -- interactive input of vector */ +VEC *ifin_vec(fp,vec) +FILE *fp; +VEC *vec; +{ + u_int i,dim,dynamic; /* dynamic set if memory allocated here */ + + /* get vector dimension */ + if ( vec != (VEC *)NULL && vec->dimdim; dynamic = FALSE; } + else + { + dynamic = TRUE; + do + { + fprintf(stderr,"Vector: dim: "); + if ( fgets(line,MAXLINE,fp)==NULL ) + error(E_INPUT,"ifin_vec"); + } while ( sscanf(line,"%u",&dim)<1 || dim>MAXDIM ); + vec = v_get(dim); + } + + /* input elements */ + for ( i=0; ive[i]); + if ( fgets(line,MAXLINE,fp)==NULL ) + error(E_INPUT,"ifin_vec"); + if ( (*line == 'b' || *line == 'B') && i > 0 ) + { i--; dynamic = FALSE; goto redo; } + if ( (*line == 'f' || *line == 'F') && i < dim-1 ) + { i++; dynamic = FALSE; goto redo; } +#if REAL == DOUBLE + } while ( *line=='\0' || sscanf(line,"%lf",&vec->ve[i]) < 1 ); +#elif REAL == FLOAT + } while ( *line=='\0' || sscanf(line,"%f",&vec->ve[i]) < 1 ); +#endif + + return (vec); +} + +/* bfin_vec -- batch-file input of vector */ +VEC *bfin_vec(fp,vec) +FILE *fp; +VEC *vec; +{ + u_int i,dim; + int io_code; + + /* get dimension */ + skipjunk(fp); + if ((io_code=fscanf(fp," Vector: dim:%u",&dim)) < 1 || + dim>MAXDIM ) + error(io_code==EOF ? 7 : 6,"bfin_vec"); + + /* allocate memory if necessary */ + if ( vec==(VEC *)NULL || vec->dim != dim ) + vec = v_resize(vec,dim); + + /* get entries */ + skipjunk(fp); + for ( i=0; ive[i])) < 1 ) +#elif REAL == FLOAT + if ((io_code=fscanf(fp,"%f",&vec->ve[i])) < 1 ) +#endif + error(io_code==EOF ? 7 : 6,"bfin_vec"); + + return (vec); +} + +/************************************************************************** + Output routines + **************************************************************************/ +static char *format = "%14.9g "; + +char *setformat(f_string) +char *f_string; +{ + char *old_f_string; + old_f_string = format; + if ( f_string != (char *)NULL && *f_string != '\0' ) + format = f_string; + + return old_f_string; +} + +void m_foutput(fp,a) +FILE *fp; +MAT *a; +{ + u_int i, j, tmp; + + if ( a == (MAT *)NULL ) + { fprintf(fp,"Matrix: NULL\n"); return; } + fprintf(fp,"Matrix: %d by %d\n",a->m,a->n); + if ( a->me == (Real **)NULL ) + { fprintf(fp,"NULL\n"); return; } + for ( i=0; im; i++ ) /* for each row... */ + { + fprintf(fp,"row %u: ",i); + for ( j=0, tmp=2; jn; j++, tmp++ ) + { /* for each col in row... */ + fprintf(fp,format,a->me[i][j]); + if ( ! (tmp % 5) ) putc('\n',fp); + } + if ( tmp % 5 != 1 ) putc('\n',fp); + } +} + +void px_foutput(fp,px) +FILE *fp; +PERM *px; +{ + u_int i; + + if ( px == (PERM *)NULL ) + { fprintf(fp,"Permutation: NULL\n"); return; } + fprintf(fp,"Permutation: size: %u\n",px->size); + if ( px->pe == (u_int *)NULL ) + { fprintf(fp,"NULL\n"); return; } + for ( i=0; isize; i++ ) + if ( ! (i % 8) && i != 0 ) + fprintf(fp,"\n %u->%u ",i,px->pe[i]); + else + fprintf(fp,"%u->%u ",i,px->pe[i]); + fprintf(fp,"\n"); +} + +void v_foutput(fp,x) +FILE *fp; +VEC *x; +{ + u_int i, tmp; + + if ( x == (VEC *)NULL ) + { fprintf(fp,"Vector: NULL\n"); return; } + fprintf(fp,"Vector: dim: %d\n",x->dim); + if ( x->ve == (Real *)NULL ) + { fprintf(fp,"NULL\n"); return; } + for ( i=0, tmp=0; idim; i++, tmp++ ) + { + fprintf(fp,format,x->ve[i]); + if ( tmp % 5 == 4 ) putc('\n',fp); + } + if ( tmp % 5 != 0 ) putc('\n',fp); +} + + +void m_dump(fp,a) +FILE *fp; +MAT *a; +{ + u_int i, j, tmp; + + if ( a == (MAT *)NULL ) + { fprintf(fp,"Matrix: NULL\n"); return; } + fprintf(fp,"Matrix: %d by %d @ 0x%lx\n",a->m,a->n,(long)a); + fprintf(fp,"\tmax_m = %d, max_n = %d, max_size = %d\n", + a->max_m, a->max_n, a->max_size); + if ( a->me == (Real **)NULL ) + { fprintf(fp,"NULL\n"); return; } + fprintf(fp,"a->me @ 0x%lx\n",(long)(a->me)); + fprintf(fp,"a->base @ 0x%lx\n",(long)(a->base)); + for ( i=0; im; i++ ) /* for each row... */ + { + fprintf(fp,"row %u: @ 0x%lx ",i,(long)(a->me[i])); + for ( j=0, tmp=2; jn; j++, tmp++ ) + { /* for each col in row... */ + fprintf(fp,format,a->me[i][j]); + if ( ! (tmp % 5) ) putc('\n',fp); + } + if ( tmp % 5 != 1 ) putc('\n',fp); + } +} + +void px_dump(fp,px) +FILE *fp; +PERM *px; +{ + u_int i; + + if ( ! px ) + { fprintf(fp,"Permutation: NULL\n"); return; } + fprintf(fp,"Permutation: size: %u @ 0x%lx\n",px->size,(long)(px)); + if ( ! px->pe ) + { fprintf(fp,"NULL\n"); return; } + fprintf(fp,"px->pe @ 0x%lx\n",(long)(px->pe)); + for ( i=0; isize; i++ ) + fprintf(fp,"%u->%u ",i,px->pe[i]); + fprintf(fp,"\n"); +} + + +void v_dump(fp,x) +FILE *fp; +VEC *x; +{ + u_int i, tmp; + + if ( ! x ) + { fprintf(fp,"Vector: NULL\n"); return; } + fprintf(fp,"Vector: dim: %d @ 0x%lx\n",x->dim,(long)(x)); + if ( ! x->ve ) + { fprintf(fp,"NULL\n"); return; } + fprintf(fp,"x->ve @ 0x%lx\n",(long)(x->ve)); + for ( i=0, tmp=0; idim; i++, tmp++ ) + { + fprintf(fp,format,x->ve[i]); + if ( tmp % 5 == 4 ) putc('\n',fp); + } + if ( tmp % 5 != 0 ) putc('\n',fp); +} + diff --git a/meschach/matrixio.org.c b/meschach/matrixio.org.c new file mode 100644 index 0000000..36ff660 --- /dev/null +++ b/meschach/matrixio.org.c @@ -0,0 +1,522 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* 1.6 matrixio.c 11/25/87 */ + + +#include +#include +#include "matrix.h" + +static char rcsid[] = "$Id: matrixio.org.c,v 1.1 2001/03/01 17:18:49 rfranke Exp $"; + + +/* local variables */ +static char line[MAXLINE]; + + +/************************************************************************** + Input routines + **************************************************************************/ +/* skipjunk -- skips white spaces and strings of the form #....\n + Here .... is a comment string */ +int skipjunk(fp) +FILE *fp; +{ + int c; + + for ( ; ; ) /* forever do... */ + { + /* skip blanks */ + do + c = getc(fp); + while ( isspace(c) ); + + /* skip comments (if any) */ + if ( c == '#' ) + /* yes it is a comment (line) */ + while ( (c=getc(fp)) != '\n' ) + ; + else + { + ungetc(c,fp); + break; + } + } + return 0; +} + +MAT *m_finput(fp,a) +FILE *fp; +MAT *a; +{ + MAT *im_finput(),*bm_finput(); + + if ( isatty(fileno(fp)) ) + return im_finput(fp,a); + else + return bm_finput(fp,a); +} + +/* im_finput -- interactive input of matrix */ +MAT *im_finput(fp,mat) +FILE *fp; +MAT *mat; +{ + char c; + u_int i, j, m, n, dynamic; + /* dynamic set to TRUE if memory allocated here */ + + /* get matrix size */ + if ( mat != (MAT *)NULL && mat->mnm; n = mat->n; dynamic = FALSE; } + else + { + dynamic = TRUE; + do + { + fprintf(stderr,"Matrix: rows cols:"); + if ( fgets(line,MAXLINE,fp)==NULL ) + error(E_INPUT,"im_finput"); + } while ( sscanf(line,"%u%u",&m,&n)<2 || m>MAXDIM || n>MAXDIM ); + mat = m_get(m,n); + } + + /* input elements */ + for ( i=0; ime[i][j]); + if ( fgets(line,MAXLINE,fp)==NULL ) + error(E_INPUT,"im_finput"); + if ( (*line == 'b' || *line == 'B') && j > 0 ) + { j--; dynamic = FALSE; goto redo2; } + if ( (*line == 'f' || *line == 'F') && j < n-1 ) + { j++; dynamic = FALSE; goto redo2; } +#if REAL == DOUBLE + } while ( *line=='\0' || sscanf(line,"%lf",&mat->me[i][j])<1 ); +#elif REAL == FLOAT + } while ( *line=='\0' || sscanf(line,"%f",&mat->me[i][j])<1 ); +#endif + fprintf(stderr,"Continue: "); + fscanf(fp,"%c",&c); + if ( c == 'n' || c == 'N' ) + { dynamic = FALSE; goto redo; } + if ( (c == 'b' || c == 'B') /* && i > 0 */ ) + { if ( i > 0 ) + i--; + dynamic = FALSE; goto redo; + } + } + + return (mat); +} + +/* bm_finput -- batch-file input of matrix */ +MAT *bm_finput(fp,mat) +FILE *fp; +MAT *mat; +{ + u_int i,j,m,n,dummy; + int io_code; + + /* get dimension */ + skipjunk(fp); + if ((io_code=fscanf(fp," Matrix: %u by %u",&m,&n)) < 2 || + m>MAXDIM || n>MAXDIM ) + error(io_code==EOF ? E_EOF : E_FORMAT,"bm_finput"); + + /* allocate memory if necessary */ + if ( mat==(MAT *)NULL ) + mat = m_resize(mat,m,n); + + /* get entries */ + for ( i=0; ime[i][j])) < 1 ) +#elif REAL == FLOAT + if ((io_code=fscanf(fp,"%f",&mat->me[i][j])) < 1 ) +#endif + error(io_code==EOF ? 7 : 6,"bm_finput"); + } + + return (mat); +} + +PERM *px_finput(fp,px) +FILE *fp; +PERM *px; +{ + PERM *ipx_finput(),*bpx_finput(); + + if ( isatty(fileno(fp)) ) + return ipx_finput(fp,px); + else + return bpx_finput(fp,px); +} + + +/* ipx_finput -- interactive input of permutation */ +PERM *ipx_finput(fp,px) +FILE *fp; +PERM *px; +{ + u_int i,j,size,dynamic; /* dynamic set if memory allocated here */ + u_int entry,ok; + + /* get permutation size */ + if ( px!=(PERM *)NULL && px->sizesize; dynamic = FALSE; } + else + { + dynamic = TRUE; + do + { + fprintf(stderr,"Permutation: size: "); + if ( fgets(line,MAXLINE,fp)==NULL ) + error(E_INPUT,"ipx_finput"); + } while ( sscanf(line,"%u",&size)<1 || size>MAXDIM ); + px = px_get(size); + } + + /* get entries */ + i = 0; + while ( i%u new: ", + i,px->pe[i]); + if ( fgets(line,MAXLINE,fp)==NULL ) + error(E_INPUT,"ipx_finput"); + if ( (*line == 'b' || *line == 'B') && i > 0 ) + { i--; dynamic = FALSE; goto redo; } + } while ( *line=='\0' || sscanf(line,"%u",&entry) < 1 ); + /* check entry */ + ok = (entry < size); + for ( j=0; jpe[j]); + if ( ok ) + { + px->pe[i] = entry; + i++; + } + } + + return (px); +} + +/* bpx_finput -- batch-file input of permutation */ +PERM *bpx_finput(fp,px) +FILE *fp; +PERM *px; +{ + u_int i,j,size,entry,ok; + int io_code; + + /* get size of permutation */ + skipjunk(fp); + if ((io_code=fscanf(fp," Permutation: size:%u",&size)) < 1 || + size>MAXDIM ) + error(io_code==EOF ? 7 : 6,"bpx_finput"); + + /* allocate memory if necessary */ + if ( px==(PERM *)NULL || px->size %u",&entry)) < 1 ) + error(io_code==EOF ? 7 : 6,"bpx_finput"); + /* check entry */ + ok = (entry < size); + for ( j=0; jpe[j]); + if ( ok ) + { + px->pe[i] = entry; + i++; + } + else + error(E_BOUNDS,"bpx_finput"); + } + + return (px); +} + + +VEC *v_finput(fp,x) +FILE *fp; +VEC *x; +{ + VEC *ifin_vec(),*bfin_vec(); + + if ( isatty(fileno(fp)) ) + return ifin_vec(fp,x); + else + return bfin_vec(fp,x); +} + +/* ifin_vec -- interactive input of vector */ +VEC *ifin_vec(fp,vec) +FILE *fp; +VEC *vec; +{ + u_int i,dim,dynamic; /* dynamic set if memory allocated here */ + + /* get vector dimension */ + if ( vec != (VEC *)NULL && vec->dimdim; dynamic = FALSE; } + else + { + dynamic = TRUE; + do + { + fprintf(stderr,"Vector: dim: "); + if ( fgets(line,MAXLINE,fp)==NULL ) + error(E_INPUT,"ifin_vec"); + } while ( sscanf(line,"%u",&dim)<1 || dim>MAXDIM ); + vec = v_get(dim); + } + + /* input elements */ + for ( i=0; ive[i]); + if ( fgets(line,MAXLINE,fp)==NULL ) + error(E_INPUT,"ifin_vec"); + if ( (*line == 'b' || *line == 'B') && i > 0 ) + { i--; dynamic = FALSE; goto redo; } + if ( (*line == 'f' || *line == 'F') && i < dim-1 ) + { i++; dynamic = FALSE; goto redo; } +#if REAL == DOUBLE + } while ( *line=='\0' || sscanf(line,"%lf",&vec->ve[i]) < 1 ); +#elif REAL == FLOAT + } while ( *line=='\0' || sscanf(line,"%f",&vec->ve[i]) < 1 ); +#endif + + return (vec); +} + +/* bfin_vec -- batch-file input of vector */ +VEC *bfin_vec(fp,vec) +FILE *fp; +VEC *vec; +{ + u_int i,dim; + int io_code; + + /* get dimension */ + skipjunk(fp); + if ((io_code=fscanf(fp," Vector: dim:%u",&dim)) < 1 || + dim>MAXDIM ) + error(io_code==EOF ? 7 : 6,"bfin_vec"); + + /* allocate memory if necessary */ + if ( vec==(VEC *)NULL ) + vec = v_resize(vec,dim); + + /* get entries */ + skipjunk(fp); + for ( i=0; ive[i])) < 1 ) +#elif REAL == FLOAT + if ((io_code=fscanf(fp,"%f",&vec->ve[i])) < 1 ) +#endif + error(io_code==EOF ? 7 : 6,"bfin_vec"); + + return (vec); +} + +/************************************************************************** + Output routines + **************************************************************************/ +static char *format = "%14.9g "; + +char *setformat(f_string) +char *f_string; +{ + char *old_f_string; + old_f_string = format; + if ( f_string != (char *)NULL && *f_string != '\0' ) + format = f_string; + + return old_f_string; +} + +void m_foutput(fp,a) +FILE *fp; +MAT *a; +{ + u_int i, j, tmp; + + if ( a == (MAT *)NULL ) + { fprintf(fp,"Matrix: NULL\n"); return; } + fprintf(fp,"Matrix: %d by %d\n",a->m,a->n); + if ( a->me == (Real **)NULL ) + { fprintf(fp,"NULL\n"); return; } + for ( i=0; im; i++ ) /* for each row... */ + { + fprintf(fp,"row %u: ",i); + for ( j=0, tmp=2; jn; j++, tmp++ ) + { /* for each col in row... */ + fprintf(fp,format,a->me[i][j]); + if ( ! (tmp % 5) ) putc('\n',fp); + } + if ( tmp % 5 != 1 ) putc('\n',fp); + } +} + +void px_foutput(fp,px) +FILE *fp; +PERM *px; +{ + u_int i; + + if ( px == (PERM *)NULL ) + { fprintf(fp,"Permutation: NULL\n"); return; } + fprintf(fp,"Permutation: size: %u\n",px->size); + if ( px->pe == (u_int *)NULL ) + { fprintf(fp,"NULL\n"); return; } + for ( i=0; isize; i++ ) + if ( ! (i % 8) && i != 0 ) + fprintf(fp,"\n %u->%u ",i,px->pe[i]); + else + fprintf(fp,"%u->%u ",i,px->pe[i]); + fprintf(fp,"\n"); +} + +void v_foutput(fp,x) +FILE *fp; +VEC *x; +{ + u_int i, tmp; + + if ( x == (VEC *)NULL ) + { fprintf(fp,"Vector: NULL\n"); return; } + fprintf(fp,"Vector: dim: %d\n",x->dim); + if ( x->ve == (Real *)NULL ) + { fprintf(fp,"NULL\n"); return; } + for ( i=0, tmp=0; idim; i++, tmp++ ) + { + fprintf(fp,format,x->ve[i]); + if ( tmp % 5 == 4 ) putc('\n',fp); + } + if ( tmp % 5 != 0 ) putc('\n',fp); +} + + +void m_dump(fp,a) +FILE *fp; +MAT *a; +{ + u_int i, j, tmp; + + if ( a == (MAT *)NULL ) + { fprintf(fp,"Matrix: NULL\n"); return; } + fprintf(fp,"Matrix: %d by %d @ 0x%lx\n",a->m,a->n,(long)a); + fprintf(fp,"\tmax_m = %d, max_n = %d, max_size = %d\n", + a->max_m, a->max_n, a->max_size); + if ( a->me == (Real **)NULL ) + { fprintf(fp,"NULL\n"); return; } + fprintf(fp,"a->me @ 0x%lx\n",(long)(a->me)); + fprintf(fp,"a->base @ 0x%lx\n",(long)(a->base)); + for ( i=0; im; i++ ) /* for each row... */ + { + fprintf(fp,"row %u: @ 0x%lx ",i,(long)(a->me[i])); + for ( j=0, tmp=2; jn; j++, tmp++ ) + { /* for each col in row... */ + fprintf(fp,format,a->me[i][j]); + if ( ! (tmp % 5) ) putc('\n',fp); + } + if ( tmp % 5 != 1 ) putc('\n',fp); + } +} + +void px_dump(fp,px) +FILE *fp; +PERM *px; +{ + u_int i; + + if ( ! px ) + { fprintf(fp,"Permutation: NULL\n"); return; } + fprintf(fp,"Permutation: size: %u @ 0x%lx\n",px->size,(long)(px)); + if ( ! px->pe ) + { fprintf(fp,"NULL\n"); return; } + fprintf(fp,"px->pe @ 0x%lx\n",(long)(px->pe)); + for ( i=0; isize; i++ ) + fprintf(fp,"%u->%u ",i,px->pe[i]); + fprintf(fp,"\n"); +} + + +void v_dump(fp,x) +FILE *fp; +VEC *x; +{ + u_int i, tmp; + + if ( ! x ) + { fprintf(fp,"Vector: NULL\n"); return; } + fprintf(fp,"Vector: dim: %d @ 0x%lx\n",x->dim,(long)(x)); + if ( ! x->ve ) + { fprintf(fp,"NULL\n"); return; } + fprintf(fp,"x->ve @ 0x%lx\n",(long)(x->ve)); + for ( i=0, tmp=0; idim; i++, tmp++ ) + { + fprintf(fp,format,x->ve[i]); + if ( tmp % 5 == 4 ) putc('\n',fp); + } + if ( tmp % 5 != 0 ) putc('\n',fp); +} + diff --git a/meschach/maxint.c b/meschach/maxint.c new file mode 100644 index 0000000..b0282ee --- /dev/null +++ b/meschach/maxint.c @@ -0,0 +1,38 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +main() +{ + int i, old_i; + + i = 1; + while ( i > 0 ) + { + old_i = i; + i = (i << 1) | 1; + } + printf("%d\n", old_i); +} diff --git a/meschach/meminfo.c b/meschach/meminfo.c new file mode 100644 index 0000000..6ed01ed --- /dev/null +++ b/meschach/meminfo.c @@ -0,0 +1,394 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* meminfo.c revised 22/11/93 */ + +/* + contains basic functions, types and arrays + to keep track of memory allocation/deallocation +*/ + +#include +#include "matrix.h" +#include "meminfo.h" +#ifdef COMPLEX +#include "zmatrix.h" +#endif +#ifdef SPARSE +#include "sparse.h" +#include "iter.h" +#endif + +static char rcsid[] = "$Id: meminfo.c,v 1.1 2001/03/01 17:18:50 rfranke Exp $"; + +/* this array is defined further in this file */ +extern MEM_CONNECT mem_connect[MEM_CONNECT_MAX_LISTS]; + + +/* names of types */ +static char *mem_type_names[] = { + "MAT", + "BAND", + "PERM", + "VEC", + "IVEC" +#ifdef SPARSE + ,"ITER", + "SPROW", + "SPMAT" +#endif +#ifdef COMPLEX + ,"ZVEC", + "ZMAT" +#endif + }; + + +#define MEM_NUM_STD_TYPES (sizeof(mem_type_names)/sizeof(mem_type_names[0])) + + +/* local array for keeping track of memory */ +static MEM_ARRAY mem_info_sum[MEM_NUM_STD_TYPES]; + + +/* for freeing various types */ +static int (*mem_free_funcs[MEM_NUM_STD_TYPES])() = { + m_free, + bd_free, + px_free, + v_free, + iv_free +#ifdef SPARSE + ,iter_free, + sprow_free, + sp_free +#endif +#ifdef COMPLEX + ,zv_free, + zm_free +#endif + }; + + + +/* it is a global variable for passing + pointers to local arrays defined here */ +MEM_CONNECT mem_connect[MEM_CONNECT_MAX_LISTS] = { + { mem_type_names, mem_free_funcs, MEM_NUM_STD_TYPES, + mem_info_sum } +}; + + +/* attach a new list of types */ + +int mem_attach_list(list, ntypes, type_names, free_funcs, info_sum) +int list,ntypes; /* number of a list and number of types there */ +char *type_names[]; /* list of names of types */ +int (*free_funcs[])(); /* list of releasing functions */ +MEM_ARRAY info_sum[]; /* local table */ +{ + if (list < 0 || list >= MEM_CONNECT_MAX_LISTS) + return -1; + + if (type_names == NULL || free_funcs == NULL + || info_sum == NULL || ntypes < 0) + return -1; + + /* if a list exists do not overwrite */ + if ( mem_connect[list].ntypes != 0 ) + error(E_OVERWRITE,"mem_attach_list"); + + mem_connect[list].ntypes = ntypes; + mem_connect[list].type_names = type_names; + mem_connect[list].free_funcs = free_funcs; + mem_connect[list].info_sum = info_sum; + return 0; +} + + +/* release a list of types */ +int mem_free_vars(list) +int list; +{ + if (list < 0 || list >= MEM_CONNECT_MAX_LISTS) + return -1; + + mem_connect[list].ntypes = 0; + mem_connect[list].type_names = NULL; + mem_connect[list].free_funcs = NULL; + mem_connect[list].info_sum = NULL; + + return 0; +} + + + +/* check if list is attached */ + +int mem_is_list_attached(list) +int list; +{ + if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS ) + return FALSE; + + if ( mem_connect[list].type_names != NULL && + mem_connect[list].free_funcs != NULL && + mem_connect[list].info_sum != NULL) + return TRUE; + else return FALSE; +} + +/* to print out the contents of mem_connect[list] */ + +void mem_dump_list(fp,list) +FILE *fp; +int list; +{ + int i; + MEM_CONNECT *mlist; + + if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS ) + return; + + mlist = &mem_connect[list]; + fprintf(fp," %15s[%d]:\n","CONTENTS OF mem_connect",list); + fprintf(fp," %-7s %-12s %-9s %s\n", + "name of", + "alloc.", "# alloc.", + "address" + ); + fprintf(fp," %-7s %-12s %-9s %s\n", + " type", + "bytes", "variables", + "of *_free()" + ); + + for (i=0; i < mlist->ntypes; i++) + fprintf(fp," %-7s %-12ld %-9d %p\n", + mlist->type_names[i], mlist->info_sum[i].bytes, + mlist->info_sum[i].numvar, mlist->free_funcs[i] + ); + + fprintf(fp,"\n"); +} + + + +/*=============================================================*/ + + +/* local variables */ + +static int mem_switched_on = MEM_SWITCH_ON_DEF; /* on/off */ + + +/* switch on/off memory info */ + +int mem_info_on(sw) +int sw; +{ + int old = mem_switched_on; + + mem_switched_on = sw; + return old; +} + +#ifdef ANSI_C +int mem_info_is_on(void) +#else +int mem_info_is_on() +#endif +{ + return mem_switched_on; +} + + +/* information about allocated memory */ + +/* return the number of allocated bytes for type 'type' */ + +long mem_info_bytes(type,list) +int type,list; +{ + if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS ) + return 0l; + if ( !mem_switched_on || type < 0 + || type >= mem_connect[list].ntypes + || mem_connect[list].free_funcs[type] == NULL ) + return 0l; + + return mem_connect[list].info_sum[type].bytes; +} + +/* return the number of allocated variables for type 'type' */ +int mem_info_numvar(type,list) +int type,list; +{ + if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS ) + return 0l; + if ( !mem_switched_on || type < 0 + || type >= mem_connect[list].ntypes + || mem_connect[list].free_funcs[type] == NULL ) + return 0l; + + return mem_connect[list].info_sum[type].numvar; +} + + + +/* print out memory info to the file fp */ +void mem_info_file(fp,list) +FILE *fp; +int list; +{ + unsigned int type; + long t = 0l, d; + int n = 0, nt = 0; + MEM_CONNECT *mlist; + + if (!mem_switched_on) return; + if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS ) + return; + + if (list == 0) + fprintf(fp," MEMORY INFORMATION (standard types):\n"); + else + fprintf(fp," MEMORY INFORMATION (list no. %d):\n",list); + + mlist = &mem_connect[list]; + + for (type=0; type < mlist->ntypes; type++) { + if (mlist->type_names[type] == NULL ) continue; + d = mlist->info_sum[type].bytes; + t += d; + n = mlist->info_sum[type].numvar; + nt += n; + fprintf(fp," type %-7s %10ld alloc. byte%c %6d alloc. variable%c\n", + mlist->type_names[type], d, (d!=1 ? 's' : ' '), + n, (n!=1 ? 's' : ' ')); + } + + fprintf(fp," %-12s %10ld alloc. byte%c %6d alloc. variable%c\n\n", + "total:",t, (t!=1 ? 's' : ' '), + nt, (nt!=1 ? 's' : ' ')); +} + + +/* function for memory information */ + + +/* mem_bytes_list + + Arguments: + type - the number of type; + old_size - old size of allocated memory (in bytes); + new_size - new size of allocated memory (in bytes); + list - list of types + */ + + +void mem_bytes_list(type,old_size,new_size,list) +int type,list; +int old_size,new_size; +{ + MEM_CONNECT *mlist; + +if (list != 0) + fprintf(stderr, "list is != 0\n"); + + if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS ) + return; + + mlist = &mem_connect[list]; + if ( type < 0 || type >= mlist->ntypes + || mlist->free_funcs[type] == NULL ) + return; + + if ( old_size < 0 || new_size < 0 ) + error(E_NEG,"mem_bytes_list"); + + mlist->info_sum[type].bytes += new_size - old_size; + + /* check if the number of bytes is non-negative */ + if ( old_size > 0 ) { + + if (mlist->info_sum[type].bytes < 0) + { + fprintf(stderr, + "\n WARNING !! memory info: allocated memory is less than 0\n"); + fprintf(stderr,"\t TYPE %s \n\n", mlist->type_names[type]); + + if ( !isatty(fileno(stdout)) ) { + fprintf(stdout, + "\n WARNING !! memory info: allocated memory is less than 0\n"); + fprintf(stdout,"\t TYPE %s \n\n", mlist->type_names[type]); + } + } + } +} + + +/* mem_numvar_list + + Arguments: + type - the number of type; + num - # of variables allocated (> 0) or deallocated ( < 0) + list - list of types + */ + + +void mem_numvar_list(type,num,list) +int type,list,num; +{ + MEM_CONNECT *mlist; + + if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS ) + return; + + mlist = &mem_connect[list]; + if ( type < 0 || type >= mlist->ntypes + || mlist->free_funcs[type] == NULL ) + return; + + mlist->info_sum[type].numvar += num; + + /* check if the number of variables is non-negative */ + if ( num < 0 ) { + + if (mlist->info_sum[type].numvar < 0) + { + fprintf(stderr, + "\n WARNING !! memory info: allocated # of variables is less than 0\n"); + fprintf(stderr,"\t TYPE %s \n\n", mlist->type_names[type]); + if ( !isatty(fileno(stdout)) ) { + fprintf(stdout, + "\n WARNING !! memory info: allocated # of variables is less than 0\n"); + fprintf(stdout,"\t TYPE %s \n\n", mlist->type_names[type]); + } + } + } +} + diff --git a/meschach/meminfo.h b/meschach/meminfo.h new file mode 100644 index 0000000..1a1309b --- /dev/null +++ b/meschach/meminfo.h @@ -0,0 +1,155 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* meminfo.h 26/08/93 */ +/* changed 11/12/93 */ + + +#ifndef MEM_INFOH +#define MEM_INFOH + + + +/* for hash table in mem_stat.c */ +/* Note: the hash size should be a prime, or at very least odd */ +#define MEM_HASHSIZE 509 +#define MEM_HASHSIZE_FILE "meminfo.h" + + +/* default: memory information is off */ +/* set it to 1 if you want it all the time */ +#define MEM_SWITCH_ON_DEF 1 + + +/* available standard types */ +#define TYPE_NULL (-1) +#define TYPE_MAT 0 +#define TYPE_BAND 1 +#define TYPE_PERM 2 +#define TYPE_VEC 3 +#define TYPE_IVEC 4 + +#ifdef SPARSE +#define TYPE_ITER 5 +#define TYPE_SPROW 6 +#define TYPE_SPMAT 7 +#endif + +#ifdef COMPLEX +#ifdef SPARSE +#define TYPE_ZVEC 8 +#define TYPE_ZMAT 9 +#else +#define TYPE_ZVEC 5 +#define TYPE_ZMAT 6 +#endif +#endif + +/* structure for memory information */ +typedef struct { + long bytes; /* # of allocated bytes for each type (summary) */ + int numvar; /* # of allocated variables for each type */ +} MEM_ARRAY; + + + +#ifdef ANSI_C + +int mem_info_is_on(void); +int mem_info_on(int sw); + +long mem_info_bytes(int type,int list); +int mem_info_numvar(int type,int list); +void mem_info_file(FILE * fp,int list); + +void mem_bytes_list(int type,int old_size,int new_size, + int list); +void mem_numvar_list(int type, int num, int list); + +int mem_stat_reg_list(void **var,int type,int list); +int mem_stat_mark(int mark); +int mem_stat_free_list(int mark,int list); +int mem_stat_show_mark(void); +void mem_stat_dump(FILE *fp,int list); +int mem_attach_list(int list,int ntypes,char *type_names[], + int (*free_funcs[])(), MEM_ARRAY info_sum[]); +int mem_free_vars(int list); +int mem_is_list_attached(int list); +void mem_dump_list(FILE *fp,int list); +int mem_stat_reg_vars(int list,int type,...); + +#else +int mem_info_is_on(); +int mem_info_on(); + +long mem_info_bytes(); +int mem_info_numvar(); +void mem_info_file(); + +void mem_bytes_list(); +void mem_numvar_list(); + +int mem_stat_reg_list(); +int mem_stat_mark(); +int mem_stat_free_list(); +int mem_stat_show_mark(); +void mem_stat_dump(); +int mem_attach_list(); +int mem_free_vars(); +int mem_is_list_attached(); +void mem_dump_list(); +int mem_stat_reg_vars(); + +#endif + +/* macros */ + +#define mem_info() mem_info_file(stdout,0) + +#define mem_stat_reg(var,type) mem_stat_reg_list((void **)var,type,0) +#define MEM_STAT_REG(var,type) mem_stat_reg_list((void **)&(var),type,0) +#define mem_stat_free(mark) mem_stat_free_list(mark,0) + +#define mem_bytes(type,old_size,new_size) \ + mem_bytes_list(type,old_size,new_size,0) + +#define mem_numvar(type,num) mem_numvar_list(type,num,0) + + +/* internal type */ + +typedef struct { + char **type_names; /* array of names of types (strings) */ + int (**free_funcs)(); /* array of functions for releasing types */ + unsigned ntypes; /* max number of types */ + MEM_ARRAY *info_sum; /* local array for keeping track of memory */ +} MEM_CONNECT; + +/* max number of lists of types */ +#define MEM_CONNECT_MAX_LISTS 5 + + +#endif diff --git a/meschach/memory.c b/meschach/memory.c new file mode 100644 index 0000000..36ff756 --- /dev/null +++ b/meschach/memory.c @@ -0,0 +1,1003 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* memory.c 1.3 11/25/87 */ + +#include "matrix.h" + + +static char rcsid[] = "$Id: memory.c,v 1.1 2001/03/01 17:18:52 rfranke Exp $"; + +/* m_get -- gets an mxn matrix (in MAT form) by dynamic memory allocation */ +MAT *m_get(m,n) +int m,n; +{ + MAT *matrix; + int i; + + if (m < 0 || n < 0) + error(E_NEG,"m_get"); + + if ((matrix=NEW(MAT)) == (MAT *)NULL ) + error(E_MEM,"m_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_MAT,0,sizeof(MAT)); + mem_numvar(TYPE_MAT,1); + } + + matrix->m = m; matrix->n = matrix->max_n = n; + matrix->max_m = m; matrix->max_size = m*n; +#ifndef SEGMENTED + if ((matrix->base = NEW_A(m*n,Real)) == (Real *)NULL ) + { + free(matrix); + error(E_MEM,"m_get"); + } + else if (mem_info_is_on()) { + mem_bytes(TYPE_MAT,0,m*n*sizeof(Real)); + } +#else + matrix->base = (Real *)NULL; +#endif + if ((matrix->me = (Real **)calloc(m,sizeof(Real *))) == + (Real **)NULL ) + { free(matrix->base); free(matrix); + error(E_MEM,"m_get"); + } + else if (mem_info_is_on()) { + mem_bytes(TYPE_MAT,0,m*sizeof(Real *)); + } + +#ifndef SEGMENTED + /* set up pointers */ + for ( i=0; ime[i] = &(matrix->base[i*n]); +#else + for ( i = 0; i < m; i++ ) + if ( (matrix->me[i]=NEW_A(n,Real)) == (Real *)NULL ) + error(E_MEM,"m_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_MAT,0,n*sizeof(Real)); + } +#endif + + return (matrix); +} + + +/* px_get -- gets a PERM of given 'size' by dynamic memory allocation + -- Note: initialized to the identity permutation */ +PERM *px_get(size) +int size; +{ + PERM *permute; + int i; + + if (size < 0) + error(E_NEG,"px_get"); + + if ((permute=NEW(PERM)) == (PERM *)NULL ) + error(E_MEM,"px_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_PERM,0,sizeof(PERM)); + mem_numvar(TYPE_PERM,1); + } + + permute->size = permute->max_size = size; + if ((permute->pe = NEW_A(size,u_int)) == (u_int *)NULL ) + error(E_MEM,"px_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_PERM,0,size*sizeof(u_int)); + } + + for ( i=0; ipe[i] = i; + + return (permute); +} + +/* v_get -- gets a VEC of dimension 'dim' + -- Note: initialized to zero */ +VEC *v_get(size) +int size; +{ + VEC *vector; + + if (size < 0) + error(E_NEG,"v_get"); + + if ((vector=NEW(VEC)) == (VEC *)NULL ) + error(E_MEM,"v_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_VEC,0,sizeof(VEC)); + mem_numvar(TYPE_VEC,1); + } + + vector->dim = vector->max_dim = size; + if ((vector->ve=NEW_A(size,Real)) == (Real *)NULL ) + { + free(vector); + error(E_MEM,"v_get"); + } + else if (mem_info_is_on()) { + mem_bytes(TYPE_VEC,0,size*sizeof(Real)); + } + + return (vector); +} + +/* m_free -- returns MAT & asoociated memory back to memory heap */ +int m_free(mat) +MAT *mat; +{ +#ifdef SEGMENTED + int i; +#endif + + if ( mat==(MAT *)NULL || (int)(mat->m) < 0 || + (int)(mat->n) < 0 ) + /* don't trust it */ + return (-1); + +#ifndef SEGMENTED + if ( mat->base != (Real *)NULL ) { + if (mem_info_is_on()) { + mem_bytes(TYPE_MAT,mat->max_m*mat->max_n*sizeof(Real),0); + } + free((char *)(mat->base)); + } +#else + for ( i = 0; i < mat->max_m; i++ ) + if ( mat->me[i] != (Real *)NULL ) { + if (mem_info_is_on()) { + mem_bytes(TYPE_MAT,mat->max_n*sizeof(Real),0); + } + free((char *)(mat->me[i])); + } +#endif + if ( mat->me != (Real **)NULL ) { + if (mem_info_is_on()) { + mem_bytes(TYPE_MAT,mat->max_m*sizeof(Real *),0); + } + free((char *)(mat->me)); + } + + if (mem_info_is_on()) { + mem_bytes(TYPE_MAT,sizeof(MAT),0); + mem_numvar(TYPE_MAT,-1); + } + free((char *)mat); + + return (0); +} + + + +/* px_free -- returns PERM & asoociated memory back to memory heap */ +int px_free(px) +PERM *px; +{ + if ( px==(PERM *)NULL || (int)(px->size) < 0 ) + /* don't trust it */ + return (-1); + + if ( px->pe == (u_int *)NULL ) { + if (mem_info_is_on()) { + mem_bytes(TYPE_PERM,sizeof(PERM),0); + mem_numvar(TYPE_PERM,-1); + } + free((char *)px); + } + else + { + if (mem_info_is_on()) { + mem_bytes(TYPE_PERM,sizeof(PERM)+px->max_size*sizeof(u_int),0); + mem_numvar(TYPE_PERM,-1); + } + free((char *)px->pe); + free((char *)px); + } + + return (0); +} + + + +/* v_free -- returns VEC & asoociated memory back to memory heap */ +int v_free(vec) +VEC *vec; +{ + if ( vec==(VEC *)NULL || (int)(vec->dim) < 0 ) + /* don't trust it */ + return (-1); + + if ( vec->ve == (Real *)NULL ) { + if (mem_info_is_on()) { + mem_bytes(TYPE_VEC,sizeof(VEC),0); + mem_numvar(TYPE_VEC,-1); + } + free((char *)vec); + } + else + { + if (mem_info_is_on()) { + mem_bytes(TYPE_VEC,sizeof(VEC)+vec->max_dim*sizeof(Real),0); + mem_numvar(TYPE_VEC,-1); + } + free((char *)vec->ve); + free((char *)vec); + } + + return (0); +} + + + +/* m_resize -- returns the matrix A of size new_m x new_n; A is zeroed + -- if A == NULL on entry then the effect is equivalent to m_get() */ +MAT *m_resize(A,new_m,new_n) +MAT *A; +int new_m, new_n; +{ + int i; + int new_max_m, new_max_n, new_size, old_m, old_n; + + if (new_m < 0 || new_n < 0) + error(E_NEG,"m_resize"); + + if ( ! A ) + return m_get(new_m,new_n); + + /* nothing was changed */ + if (new_m == A->m && new_n == A->n) + return A; + + old_m = A->m; old_n = A->n; + if ( new_m > A->max_m ) + { /* re-allocate A->me */ + if (mem_info_is_on()) { + mem_bytes(TYPE_MAT,A->max_m*sizeof(Real *), + new_m*sizeof(Real *)); + } + + A->me = RENEW(A->me,new_m,Real *); + if ( ! A->me ) + error(E_MEM,"m_resize"); + } + new_max_m = max(new_m,A->max_m); + new_max_n = max(new_n,A->max_n); + +#ifndef SEGMENTED + new_size = new_max_m*new_max_n; + if ( new_size > A->max_size ) + { /* re-allocate A->base */ + if (mem_info_is_on()) { + mem_bytes(TYPE_MAT,A->max_m*A->max_n*sizeof(Real), + new_size*sizeof(Real)); + } + + A->base = RENEW(A->base,new_size,Real); + if ( ! A->base ) + error(E_MEM,"m_resize"); + A->max_size = new_size; + } + + /* now set up A->me[i] */ + for ( i = 0; i < new_m; i++ ) + A->me[i] = &(A->base[i*new_n]); + + /* now shift data in matrix */ + if ( old_n > new_n ) + { + for ( i = 1; i < min(old_m,new_m); i++ ) + MEM_COPY((char *)&(A->base[i*old_n]), + (char *)&(A->base[i*new_n]), + sizeof(Real)*new_n); + } + else if ( old_n < new_n ) + { + for ( i = (int)(min(old_m,new_m))-1; i > 0; i-- ) + { /* copy & then zero extra space */ + MEM_COPY((char *)&(A->base[i*old_n]), + (char *)&(A->base[i*new_n]), + sizeof(Real)*old_n); + __zero__(&(A->base[i*new_n+old_n]),(new_n-old_n)); + } + __zero__(&(A->base[old_n]),(new_n-old_n)); + A->max_n = new_n; + } + /* zero out the new rows.. */ + for ( i = old_m; i < new_m; i++ ) + __zero__(&(A->base[i*new_n]),new_n); +#else + if ( A->max_n < new_n ) + { + Real *tmp; + + for ( i = 0; i < A->max_m; i++ ) + { + if (mem_info_is_on()) { + mem_bytes(TYPE_MAT,A->max_n*sizeof(Real), + new_max_n*sizeof(Real)); + } + + if ( (tmp = RENEW(A->me[i],new_max_n,Real)) == NULL ) + error(E_MEM,"m_resize"); + else { + A->me[i] = tmp; + } + } + for ( i = A->max_m; i < new_max_m; i++ ) + { + if ( (tmp = NEW_A(new_max_n,Real)) == NULL ) + error(E_MEM,"m_resize"); + else { + A->me[i] = tmp; + + if (mem_info_is_on()) { + mem_bytes(TYPE_MAT,0,new_max_n*sizeof(Real)); + } + } + } + } + else if ( A->max_m < new_m ) + { + for ( i = A->max_m; i < new_m; i++ ) + if ( (A->me[i] = NEW_A(new_max_n,Real)) == NULL ) + error(E_MEM,"m_resize"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_MAT,0,new_max_n*sizeof(Real)); + } + + } + + if ( old_n < new_n ) + { + for ( i = 0; i < old_m; i++ ) + __zero__(&(A->me[i][old_n]),new_n-old_n); + } + + /* zero out the new rows.. */ + for ( i = old_m; i < new_m; i++ ) + __zero__(A->me[i],new_n); +#endif + + A->max_m = new_max_m; + A->max_n = new_max_n; + A->max_size = A->max_m*A->max_n; + A->m = new_m; A->n = new_n; + + return A; +} + +/* px_resize -- returns the permutation px with size new_size + -- px is set to the identity permutation */ +PERM *px_resize(px,new_size) +PERM *px; +int new_size; +{ + int i; + + if (new_size < 0) + error(E_NEG,"px_resize"); + + if ( ! px ) + return px_get(new_size); + + /* nothing is changed */ + if (new_size == px->size) + return px; + + if ( new_size > px->max_size ) + { + if (mem_info_is_on()) { + mem_bytes(TYPE_PERM,px->max_size*sizeof(u_int), + new_size*sizeof(u_int)); + } + px->pe = RENEW(px->pe,new_size,u_int); + if ( ! px->pe ) + error(E_MEM,"px_resize"); + px->max_size = new_size; + } + if ( px->size <= new_size ) + /* extend permutation */ + for ( i = px->size; i < new_size; i++ ) + px->pe[i] = i; + else + for ( i = 0; i < new_size; i++ ) + px->pe[i] = i; + + px->size = new_size; + + return px; +} + +/* v_resize -- returns the vector x with dim new_dim + -- x is set to the zero vector */ +VEC *v_resize(x,new_dim) +VEC *x; +int new_dim; +{ + + if (new_dim < 0) + error(E_NEG,"v_resize"); + + if ( ! x ) + return v_get(new_dim); + + /* nothing is changed */ + if (new_dim == x->dim) + return x; + + if ( x->dim > 0 && x->max_dim == 0 ) /* assume that it's from sub_vec */ + return v_get(new_dim); + + if ( new_dim > x->max_dim ) + { + if (mem_info_is_on()) { + mem_bytes(TYPE_VEC,x->max_dim*sizeof(Real), + new_dim*sizeof(Real)); + } + + x->ve = RENEW(x->ve,new_dim,Real); + if ( ! x->ve ) + error(E_MEM,"v_resize"); + x->max_dim = new_dim; + } + + if ( new_dim > x->dim ) + __zero__(&(x->ve[x->dim]),new_dim - x->dim); + x->dim = new_dim; + + return x; +} + + + + +/* Varying number of arguments */ +/* other functions of this type are in sparse.c and zmemory.c */ + + + +#ifdef ANSI_C + + +/* To allocate memory to many arguments. + The function should be called: + v_get_vars(dim,&x,&y,&z,...,NULL); + where + int dim; + VEC *x, *y, *z,...; + The last argument should be NULL ! + dim is the length of vectors x,y,z,... + returned value is equal to the number of allocated variables + Other gec_... functions are similar. +*/ + +int v_get_vars(int dim,...) +{ + va_list ap; + int i=0; + VEC **par; + + va_start(ap, dim); + while (par = va_arg(ap,VEC **)) { /* NULL ends the list*/ + *par = v_get(dim); + i++; + } + + va_end(ap); + return i; +} + + +int iv_get_vars(int dim,...) +{ + va_list ap; + int i=0; + IVEC **par; + + va_start(ap, dim); + while (par = va_arg(ap,IVEC **)) { /* NULL ends the list*/ + *par = iv_get(dim); + i++; + } + + va_end(ap); + return i; +} + +int m_get_vars(int m,int n,...) +{ + va_list ap; + int i=0; + MAT **par; + + va_start(ap, n); + while (par = va_arg(ap,MAT **)) { /* NULL ends the list*/ + *par = m_get(m,n); + i++; + } + + va_end(ap); + return i; +} + +int px_get_vars(int dim,...) +{ + va_list ap; + int i=0; + PERM **par; + + va_start(ap, dim); + while (par = va_arg(ap,PERM **)) { /* NULL ends the list*/ + *par = px_get(dim); + i++; + } + + va_end(ap); + return i; +} + + + +/* To resize memory for many arguments. + The function should be called: + v_resize_vars(new_dim,&x,&y,&z,...,NULL); + where + int new_dim; + VEC *x, *y, *z,...; + The last argument should be NULL ! + rdim is the resized length of vectors x,y,z,... + returned value is equal to the number of allocated variables. + If one of x,y,z,.. arguments is NULL then memory is allocated to this + argument. + Other *_resize_list() functions are similar. +*/ + +int v_resize_vars(int new_dim,...) +{ + va_list ap; + int i=0; + VEC **par; + + va_start(ap, new_dim); + while (par = va_arg(ap,VEC **)) { /* NULL ends the list*/ + *par = v_resize(*par,new_dim); + i++; + } + + va_end(ap); + return i; +} + + + +int iv_resize_vars(int new_dim,...) +{ + va_list ap; + int i=0; + IVEC **par; + + va_start(ap, new_dim); + while (par = va_arg(ap,IVEC **)) { /* NULL ends the list*/ + *par = iv_resize(*par,new_dim); + i++; + } + + va_end(ap); + return i; +} + +int m_resize_vars(int m,int n,...) +{ + va_list ap; + int i=0; + MAT **par; + + va_start(ap, n); + while (par = va_arg(ap,MAT **)) { /* NULL ends the list*/ + *par = m_resize(*par,m,n); + i++; + } + + va_end(ap); + return i; +} + + +int px_resize_vars(int new_dim,...) +{ + va_list ap; + int i=0; + PERM **par; + + va_start(ap, new_dim); + while (par = va_arg(ap,PERM **)) { /* NULL ends the list*/ + *par = px_resize(*par,new_dim); + i++; + } + + va_end(ap); + return i; +} + +/* To deallocate memory for many arguments. + The function should be called: + v_free_vars(&x,&y,&z,...,NULL); + where + VEC *x, *y, *z,...; + The last argument should be NULL ! + There must be at least one not NULL argument. + returned value is equal to the number of allocated variables. + Returned value of x,y,z,.. is VNULL. + Other *_free_list() functions are similar. +*/ + + +int v_free_vars(VEC **pv,...) +{ + va_list ap; + int i=1; + VEC **par; + + v_free(*pv); + *pv = VNULL; + va_start(ap, pv); + while (par = va_arg(ap,VEC **)) { /* NULL ends the list*/ + v_free(*par); + *par = VNULL; + i++; + } + + va_end(ap); + return i; +} + + +int iv_free_vars(IVEC **ipv,...) +{ + va_list ap; + int i=1; + IVEC **par; + + iv_free(*ipv); + *ipv = IVNULL; + va_start(ap, ipv); + while (par = va_arg(ap,IVEC **)) { /* NULL ends the list*/ + iv_free(*par); + *par = IVNULL; + i++; + } + + va_end(ap); + return i; +} + + +int px_free_vars(PERM **vpx,...) +{ + va_list ap; + int i=1; + PERM **par; + + px_free(*vpx); + *vpx = PNULL; + va_start(ap, vpx); + while (par = va_arg(ap,PERM **)) { /* NULL ends the list*/ + px_free(*par); + *par = PNULL; + i++; + } + + va_end(ap); + return i; +} + +int m_free_vars(MAT **va,...) +{ + va_list ap; + int i=1; + MAT **par; + + m_free(*va); + *va = MNULL; + va_start(ap, va); + while (par = va_arg(ap,MAT **)) { /* NULL ends the list*/ + m_free(*par); + *par = MNULL; + i++; + } + + va_end(ap); + return i; +} + + +#elif VARARGS +/* old varargs is used */ + + + +/* To allocate memory to many arguments. + The function should be called: + v_get_vars(dim,&x,&y,&z,...,VNULL); + where + int dim; + VEC *x, *y, *z,...; + The last argument should be VNULL ! + dim is the length of vectors x,y,z,... +*/ + +int v_get_vars(va_alist) va_dcl +{ + va_list ap; + int dim,i=0; + VEC **par; + + va_start(ap); + dim = va_arg(ap,int); + while (par = va_arg(ap,VEC **)) { /* NULL ends the list*/ + *par = v_get(dim); + i++; + } + + va_end(ap); + return i; +} + + +int iv_get_vars(va_alist) va_dcl +{ + va_list ap; + int i=0, dim; + IVEC **par; + + va_start(ap); + dim = va_arg(ap,int); + while (par = va_arg(ap,IVEC **)) { /* NULL ends the list*/ + *par = iv_get(dim); + i++; + } + + va_end(ap); + return i; +} + +int m_get_vars(va_alist) va_dcl +{ + va_list ap; + int i=0, n, m; + MAT **par; + + va_start(ap); + m = va_arg(ap,int); + n = va_arg(ap,int); + while (par = va_arg(ap,MAT **)) { /* NULL ends the list*/ + *par = m_get(m,n); + i++; + } + + va_end(ap); + return i; +} + + + +int px_get_vars(va_alist) va_dcl +{ + va_list ap; + int i=0, dim; + PERM **par; + + va_start(ap); + dim = va_arg(ap,int); + while (par = va_arg(ap,PERM **)) { /* NULL ends the list*/ + *par = px_get(dim); + i++; + } + + va_end(ap); + return i; +} + + + +/* To resize memory for many arguments. + The function should be called: + v_resize_vars(new_dim,&x,&y,&z,...,NULL); + where + int new_dim; + VEC *x, *y, *z,...; + The last argument should be NULL ! + rdim is the resized length of vectors x,y,z,... + returned value is equal to the number of allocated variables. + If one of x,y,z,.. arguments is NULL then memory is allocated to this + argument. + Other *_resize_list() functions are similar. +*/ + +int v_resize_vars(va_alist) va_dcl +{ + va_list ap; + int i=0, new_dim; + VEC **par; + + va_start(ap); + new_dim = va_arg(ap,int); + while (par = va_arg(ap,VEC **)) { /* NULL ends the list*/ + *par = v_resize(*par,new_dim); + i++; + } + + va_end(ap); + return i; +} + + + +int iv_resize_vars(va_alist) va_dcl +{ + va_list ap; + int i=0, new_dim; + IVEC **par; + + va_start(ap); + new_dim = va_arg(ap,int); + while (par = va_arg(ap,IVEC **)) { /* NULL ends the list*/ + *par = iv_resize(*par,new_dim); + i++; + } + + va_end(ap); + return i; +} + +int m_resize_vars(va_alist) va_dcl +{ + va_list ap; + int i=0, m, n; + MAT **par; + + va_start(ap); + m = va_arg(ap,int); + n = va_arg(ap,int); + while (par = va_arg(ap,MAT **)) { /* NULL ends the list*/ + *par = m_resize(*par,m,n); + i++; + } + + va_end(ap); + return i; +} + +int px_resize_vars(va_alist) va_dcl +{ + va_list ap; + int i=0, new_dim; + PERM **par; + + va_start(ap); + new_dim = va_arg(ap,int); + while (par = va_arg(ap,PERM **)) { /* NULL ends the list*/ + *par = px_resize(*par,new_dim); + i++; + } + + va_end(ap); + return i; +} + + +/* To deallocate memory for many arguments. + The function should be called: + v_free_vars(&x,&y,&z,...,NULL); + where + VEC *x, *y, *z,...; + The last argument should be NULL ! + returned value is equal to the number of allocated variables. + Returned value of x,y,z,.. is VNULL. + Other *_free_list() functions are similar. +*/ + + +int v_free_vars(va_alist) va_dcl +{ + va_list ap; + int i=0; + VEC **par; + + va_start(ap); + while (par = va_arg(ap,VEC **)) { /* NULL ends the list*/ + v_free(*par); + *par = VNULL; + i++; + } + + va_end(ap); + return i; +} + + + +int iv_free_vars(va_alist) va_dcl +{ + va_list ap; + int i=0; + IVEC **par; + + va_start(ap); + while (par = va_arg(ap,IVEC **)) { /* NULL ends the list*/ + iv_free(*par); + *par = IVNULL; + i++; + } + + va_end(ap); + return i; +} + + +int px_free_vars(va_alist) va_dcl +{ + va_list ap; + int i=0; + PERM **par; + + va_start(ap); + while (par = va_arg(ap,PERM **)) { /* NULL ends the list*/ + px_free(*par); + *par = PNULL; + i++; + } + + va_end(ap); + return i; +} + +int m_free_vars(va_alist) va_dcl +{ + va_list ap; + int i=0; + MAT **par; + + va_start(ap); + while (par = va_arg(ap,MAT **)) { /* NULL ends the list*/ + m_free(*par); + *par = MNULL; + i++; + } + + va_end(ap); + return i; +} + + + +#endif /* VARARGS */ + + diff --git a/meschach/memstat.c b/meschach/memstat.c new file mode 100644 index 0000000..44b3368 --- /dev/null +++ b/meschach/memstat.c @@ -0,0 +1,383 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* mem_stat.c 6/09/93 */ + +/* Deallocation of static arrays */ + + +#include +#include "matrix.h" +#include "meminfo.h" +#ifdef COMPLEX +#include "zmatrix.h" +#endif +#ifdef SPARSE +#include "sparse.h" +#include "iter.h" +#endif + +static char rcsid[] = "$Id: memstat.c,v 1.1 2001/03/01 17:18:52 rfranke Exp $"; + +/* global variable */ + +extern MEM_CONNECT mem_connect[MEM_CONNECT_MAX_LISTS]; + + +/* local type */ + +typedef struct { + void **var; /* for &A, where A is a pointer */ + int type; /* type of A */ + int mark; /* what mark is chosen */ +} MEM_STAT_STRUCT; + + +/* local variables */ + +/* how many marks are used */ +static int mem_stat_mark_many = 0; + +/* current mark */ +static int mem_stat_mark_curr = 0; + + +static MEM_STAT_STRUCT mem_stat_var[MEM_HASHSIZE]; + +/* array of indices (+1) to mem_stat_var */ +static unsigned int mem_hash_idx[MEM_HASHSIZE]; + +/* points to the first unused element in mem_hash_idx */ +static unsigned int mem_hash_idx_end = 0; + + + +/* hashing function */ + +static unsigned int mem_hash(ptr) +void **ptr; +{ + unsigned long lp = (unsigned long)ptr; + + return (lp % MEM_HASHSIZE); +} + + +/* look for a place in mem_stat_var */ +static int mem_lookup(var) +void **var; +{ + int k, j; + + k = mem_hash(var); + + if (mem_stat_var[k].var == var) { + return -1; + } + else if (mem_stat_var[k].var == NULL) { + return k; + } + else { /* look for an empty place */ + j = k; + while (mem_stat_var[j].var != var && j < MEM_HASHSIZE + && mem_stat_var[j].var != NULL) + j++; + + if (mem_stat_var[j].var == NULL) return j; + else if (mem_stat_var[j].var == var) return -1; + else { /* if (j == MEM_HASHSIZE) */ + j = 0; + while (mem_stat_var[j].var != var && j < k + && mem_stat_var[j].var != NULL) + j++; + if (mem_stat_var[j].var == NULL) return j; + else if (mem_stat_var[j].var == var) return -1; + else { /* if (j == k) */ + fprintf(stderr, + "\n WARNING !!! static memory: mem_stat_var is too small\n"); + fprintf(stderr, + " Increase MEM_HASHSIZE in file: %s (currently = %d)\n\n", + MEM_HASHSIZE_FILE, MEM_HASHSIZE); + if ( !isatty(fileno(stdout)) ) { + fprintf(stdout, + "\n WARNING !!! static memory: mem_stat_var is too small\n"); + fprintf(stdout, + " Increase MEM_HASHSIZE in file: %s (currently = %d)\n\n", + MEM_HASHSIZE_FILE, MEM_HASHSIZE); + } + error(E_MEM,"mem_lookup"); + } + } + } + + return -1; +} + + +/* register static variables; + Input arguments: + var - variable to be registered, + type - type of this variable; + list - list of types + + returned value < 0 --> error, + returned value == 0 --> not registered, + returned value >= 0 --> registered with this mark; +*/ + +int mem_stat_reg_list(var,type,list) +void **var; +int type,list; +{ + int n; + + if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS ) + return -1; + + if (mem_stat_mark_curr == 0) return 0; /* not registered */ + if (var == NULL) return -1; /* error */ + + if ( type < 0 || type >= mem_connect[list].ntypes || + mem_connect[list].free_funcs[type] == NULL ) + { + warning(WARN_WRONG_TYPE,"mem_stat_reg_list"); + return -1; + } + + if ((n = mem_lookup(var)) >= 0) { + mem_stat_var[n].var = var; + mem_stat_var[n].mark = mem_stat_mark_curr; + mem_stat_var[n].type = type; + /* save n+1, not n */ + mem_hash_idx[mem_hash_idx_end++] = n+1; + } + + return mem_stat_mark_curr; +} + + +/* set a mark; + Input argument: + mark - positive number denoting a mark; + returned: + mark if mark > 0, + 0 if mark == 0, + -1 if mark is negative. +*/ + +int mem_stat_mark(mark) +int mark; +{ + if (mark < 0) { + mem_stat_mark_curr = 0; + return -1; /* error */ + } + else if (mark == 0) { + mem_stat_mark_curr = 0; + return 0; + } + + mem_stat_mark_curr = mark; + mem_stat_mark_many++; + + return mark; +} + + + +/* deallocate static variables; + Input argument: + mark - a positive number denoting the mark; + + Returned: + -1 if mark < 0 (error); + 0 if mark == 0; +*/ + +int mem_stat_free_list(mark,list) +int mark,list; +{ + u_int i,j; + int (*free_fn)(); + + if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS + || mem_connect[list].free_funcs == NULL ) + return -1; + + if (mark < 0) { + mem_stat_mark_curr = 0; + return -1; + } + else if (mark == 0) { + mem_stat_mark_curr = 0; + return 0; + } + + if (mem_stat_mark_many <= 0) { + warning(WARN_NO_MARK,"mem_stat_free"); + return -1; + } + + /* deallocate the marked variables */ + for (i=0; i < mem_hash_idx_end; i++) { + j = mem_hash_idx[i]; + if (j == 0) continue; + else { + j--; + if (mem_stat_var[j].mark == mark) { + free_fn = mem_connect[list].free_funcs[mem_stat_var[j].type]; + if ( free_fn != NULL ) + (*free_fn)(*mem_stat_var[j].var); + else + warning(WARN_WRONG_TYPE,"mem_stat_free"); + + *(mem_stat_var[j].var) = NULL; + mem_stat_var[j].var = NULL; + mem_stat_var[j].mark = 0; + mem_hash_idx[i] = 0; + } + } + } + + while (mem_hash_idx_end > 0 && mem_hash_idx[mem_hash_idx_end-1] == 0) + mem_hash_idx_end--; + + mem_stat_mark_curr = 0; + mem_stat_mark_many--; + return 0; +} + + +/* only for diagnostic purposes */ + +void mem_stat_dump(fp,list) +FILE *fp; +int list; +{ + u_int i,j,k=1; + + if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS + || mem_connect[list].free_funcs == NULL ) + return; + + fprintf(fp," Array mem_stat_var (list no. %d):\n",list); + for (i=0; i < mem_hash_idx_end; i++) { + j = mem_hash_idx[i]; + if (j == 0) continue; + else { + j--; + fprintf(fp," %d. var = 0x%p, type = %s, mark = %d\n", + k,mem_stat_var[j].var, + mem_stat_var[j].type < mem_connect[list].ntypes && + mem_connect[list].free_funcs[mem_stat_var[j].type] != NULL ? + mem_connect[list].type_names[(int)mem_stat_var[j].type] : + "???", + mem_stat_var[j].mark); + k++; + } + } + + fprintf(fp,"\n"); +} + + +/* query function about the current mark */ +#ifdef ANSI_C +int mem_stat_show_mark(void) +#else +int mem_stat_show_mark() +#endif +{ + return mem_stat_mark_curr; +} + + +/* Varying number of arguments */ + + +#ifdef ANSI_C + +/* To allocate memory to many arguments. + The function should be called: + mem_stat_vars(list,type,&v1,&v2,&v3,...,VNULL); + where + int list,type; + void **v1, **v2, **v3,...; + The last argument should be VNULL ! + type is the type of variables v1,v2,v3,... + (of course they must be of the same type) +*/ + +int mem_stat_reg_vars(int list,int type,...) +{ + va_list ap; + int i=0; + void **par; + + va_start(ap, type); + while (par = va_arg(ap,void **)) { /* NULL ends the list*/ + mem_stat_reg_list(par,type,list); + i++; + } + + va_end(ap); + return i; +} + +#elif VARARGS +/* old varargs is used */ + +/* To allocate memory to many arguments. + The function should be called: + mem_stat_vars(list,type,&v1,&v2,&v3,...,VNULL); + where + int list,type; + void **v1, **v2, **v3,...; + The last argument should be VNULL ! + type is the type of variables v1,v2,v3,... + (of course they must be of the same type) +*/ + +int mem_stat_reg_vars(va_alist) va_dcl +{ + va_list ap; + int type,list,i=0; + void **par; + + va_start(ap); + list = va_arg(ap,int); + type = va_arg(ap,int); + while (par = va_arg(ap,void **)) { /* NULL ends the list*/ + mem_stat_reg_list(par,type,list); + i++; + } + + va_end(ap); + return i; +} + + +#endif diff --git a/meschach/memtort.c b/meschach/memtort.c new file mode 100644 index 0000000..290984c --- /dev/null +++ b/meschach/memtort.c @@ -0,0 +1,758 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Tests for mem_info.c functions + */ + +static char rcsid[] = "$Id: memtort.c,v 1.1 2001/03/01 17:18:53 rfranke Exp $"; + +#include +#include +#include "matrix2.h" +#include "sparse2.h" +#include "zmatrix2.h" + + +#define errmesg(mesg) printf("Error: %s error: line %d\n",mesg,__LINE__) +#define notice(mesg) printf("# Testing %s...\n",mesg) + + +/* new types list */ + +extern MEM_CONNECT mem_connect[MEM_CONNECT_MAX_LISTS]; + +/* the number of a new list */ +#define FOO_LIST 1 + +/* numbers of types */ +#define TYPE_FOO_1 1 +#define TYPE_FOO_2 2 + +typedef struct { + int dim; + int fix_dim; + Real (*a)[10]; +} FOO_1; + +typedef struct { + int dim; + int fix_dim; + Real (*a)[2]; +} FOO_2; + + + +FOO_1 *foo_1_get(dim) +int dim; +{ + FOO_1 *f; + + if ((f = (FOO_1 *)malloc(sizeof(FOO_1))) == NULL) + error(E_MEM,"foo_1_get"); + else if (mem_info_is_on()) { + mem_bytes_list(TYPE_FOO_1,0,sizeof(FOO_1),FOO_LIST); + mem_numvar_list(TYPE_FOO_1,1,FOO_LIST); + } + + f->dim = dim; + f->fix_dim = 10; + if ((f->a = (Real (*)[10])malloc(dim*sizeof(Real [10]))) == NULL) + error(E_MEM,"foo_1_get"); + else if (mem_info_is_on()) + mem_bytes_list(TYPE_FOO_1,0,dim*sizeof(Real [10]),FOO_LIST); + + return f; +} + + +FOO_2 *foo_2_get(dim) +int dim; +{ + FOO_2 *f; + + if ((f = (FOO_2 *)malloc(sizeof(FOO_2))) == NULL) + error(E_MEM,"foo_2_get"); + else if (mem_info_is_on()) { + mem_bytes_list(TYPE_FOO_2,0,sizeof(FOO_2),FOO_LIST); + mem_numvar_list(TYPE_FOO_2,1,FOO_LIST); + } + + f->dim = dim; + f->fix_dim = 2; + if ((f->a = (Real (*)[2])malloc(dim*sizeof(Real [2]))) == NULL) + error(E_MEM,"foo_2_get"); + else if (mem_info_is_on()) + mem_bytes_list(TYPE_FOO_2,0,dim*sizeof(Real [2]),FOO_LIST); + + return f; +} + + + +int foo_1_free(f) +FOO_1 *f; +{ + if ( f != NULL) { + if (mem_info_is_on()) { + mem_bytes_list(TYPE_FOO_1,sizeof(FOO_1)+ + f->dim*sizeof(Real [10]),0,FOO_LIST); + mem_numvar_list(TYPE_FOO_1,-1,FOO_LIST); + } + + free(f->a); + free(f); + } + return 0; +} + +int foo_2_free(f) +FOO_2 *f; +{ + if ( f != NULL) { + if (mem_info_is_on()) { + mem_bytes_list(TYPE_FOO_2,sizeof(FOO_2)+ + f->dim*sizeof(Real [2]),0,FOO_LIST); + mem_numvar_list(TYPE_FOO_2,-1,FOO_LIST); + } + + free(f->a); + free(f); + } + return 0; +} + + + + +char *foo_type_name[] = { + "nothing", + "FOO_1", + "FOO_2" +}; + + +#define FOO_NUM_TYPES (sizeof(foo_type_name)/sizeof(*foo_type_name)) + + +int (*foo_free_func[FOO_NUM_TYPES])() = { + NULL, + foo_1_free, + foo_2_free + }; + + + +static MEM_ARRAY foo_info_sum[FOO_NUM_TYPES]; + + + + /* px_rand -- generates sort-of random permutation */ +PERM *px_rand(pi) +PERM *pi; +{ + int i, j, k; + + if ( ! pi ) + error(E_NULL,"px_rand"); + + for ( i = 0; i < 3*pi->size; i++ ) + { + j = (rand() >> 8) % pi->size; + k = (rand() >> 8) % pi->size; + px_transp(pi,j,k); + } + + return pi; +} + +#ifdef SPARSE +SPMAT *gen_non_symm(m,n) +int m, n; +{ + SPMAT *A; + static PERM *px = PNULL; + int i, j, k, k_max; + Real s1; + + A = sp_get(m,n,8); + px = px_resize(px,n); + MEM_STAT_REG(px,TYPE_PERM); + for ( i = 0; i < A->m; i++ ) + { + k_max = 1 + ((rand() >> 8) % 10); + for ( k = 0; k < k_max; k++ ) + { + j = (rand() >> 8) % A->n; + s1 = rand()/((double)MAX_RAND); + sp_set_val(A,i,j,s1); + } + } + /* to make it likely that A is nonsingular, use pivot... */ + for ( i = 0; i < 2*A->n; i++ ) + { + j = (rand() >> 8) % A->n; + k = (rand() >> 8) % A->n; + px_transp(px,j,k); + } + for ( i = 0; i < A->n; i++ ) + sp_set_val(A,i,px->pe[i],1.0); + + + return A; +} +#endif + +void stat_test1(par) +int par; +{ + static MAT *AT = MNULL; + static VEC *xt1 = VNULL, *yt1 = VNULL; + static VEC *xt2 = VNULL, *yt2 = VNULL; + static VEC *xt3 = VNULL, *yt3 = VNULL; + static VEC *xt4 = VNULL, *yt4 = VNULL; + + AT = m_resize(AT,10,10); + xt1 = v_resize(xt1,10); + yt1 = v_resize(yt1,10); + xt2 = v_resize(xt2,10); + yt2 = v_resize(yt2,10); + xt3 = v_resize(xt3,10); + yt3 = v_resize(yt3,10); + xt4 = v_resize(xt4,10); + yt4 = v_resize(yt4,10); + + MEM_STAT_REG(AT,TYPE_MAT); + +#ifdef ANSI_C + mem_stat_reg_vars(0,TYPE_VEC,&xt1,&xt2,&xt3,&xt4,&yt1, + &yt2,&yt3,&yt4,NULL); +#else +#ifdef VARARGS + mem_stat_reg_vars(0,TYPE_VEC,&xt1,&xt2,&xt3,&xt4,&yt1, + &yt2,&yt3,&yt4,NULL); +#else + MEM_STAT_REG(xt1,TYPE_VEC); + MEM_STAT_REG(yt1,TYPE_VEC); + MEM_STAT_REG(xt2,TYPE_VEC); + MEM_STAT_REG(yt2,TYPE_VEC); + MEM_STAT_REG(xt3,TYPE_VEC); + MEM_STAT_REG(yt3,TYPE_VEC); + MEM_STAT_REG(xt4,TYPE_VEC); + MEM_STAT_REG(yt4,TYPE_VEC); +#endif +#endif + + v_rand(xt1); + m_rand(AT); + mv_mlt(AT,xt1,yt1); + +} + + +void stat_test2(par) +int par; +{ + static PERM *px = PNULL; + static IVEC *ixt = IVNULL, *iyt = IVNULL; + + px = px_resize(px,10); + ixt = iv_resize(ixt,10); + iyt = iv_resize(iyt,10); + + MEM_STAT_REG(px,TYPE_PERM); + MEM_STAT_REG(ixt,TYPE_IVEC); + MEM_STAT_REG(iyt,TYPE_IVEC); + + px_rand(px); + px_inv(px,px); +} + +#ifdef SPARSE +void stat_test3(par) +int par; +{ + static SPMAT *AT = (SPMAT *)NULL; + static VEC *xt = VNULL, *yt = VNULL; + static SPROW *r = (SPROW *) NULL; + + if (AT == (SPMAT *)NULL) + AT = gen_non_symm(100,100); + else + AT = sp_resize(AT,100,100); + xt = v_resize(xt,100); + yt = v_resize(yt,100); + if (r == NULL) r = sprow_get(100); + + MEM_STAT_REG(AT,TYPE_SPMAT); + MEM_STAT_REG(xt,TYPE_VEC); + MEM_STAT_REG(yt,TYPE_VEC); + MEM_STAT_REG(r,TYPE_SPROW); + + v_rand(xt); + sp_mv_mlt(AT,xt,yt); + +} +#endif + +#ifdef COMPLEX +void stat_test4(par) +int par; +{ + static ZMAT *AT = ZMNULL; + static ZVEC *xt = ZVNULL, *yt = ZVNULL; + + AT = zm_resize(AT,10,10); + xt = zv_resize(xt,10); + yt = zv_resize(yt,10); + + MEM_STAT_REG(AT,TYPE_ZMAT); + MEM_STAT_REG(xt,TYPE_ZVEC); + MEM_STAT_REG(yt,TYPE_ZVEC); + + zv_rand(xt); + zm_rand(AT); + zmv_mlt(AT,xt,yt); + +} +#endif + + +void main(argc, argv) +int argc; +char *argv[]; +{ + VEC *x = VNULL, *y = VNULL, *z = VNULL; + PERM *pi1 = PNULL, *pi2 = PNULL, *pi3 = PNULL; + MAT *A = MNULL, *B = MNULL, *C = MNULL; +#ifdef SPARSE + SPMAT *sA, *sB; + SPROW *r; +#endif + IVEC *ix = IVNULL, *iy = IVNULL, *iz = IVNULL; + int m,n,i,j,deg,k; + Real s1,s2; +#ifdef COMPLEX + ZVEC *zx = ZVNULL, *zy = ZVNULL, *zz = ZVNULL; + ZMAT *zA = ZMNULL, *zB = ZMNULL, *zC = ZMNULL; + complex ONE; +#endif + /* variables for testing attaching new lists of types */ + FOO_1 *foo_1; + FOO_2 *foo_2; + + + mem_info_on(TRUE); + +#if defined(ANSI_C) || defined(VARARGS) + + notice("vector initialize, copy & resize"); + + n = v_get_vars(15,&x,&y,&z,(VEC **)NULL); + if (n != 3) { + errmesg("v_get_vars"); + printf(" n = %d (should be 3)\n",n); + } + + v_rand(x); + v_rand(y); + z = v_copy(x,z); + if ( v_norm2(v_sub(x,z,z)) >= MACHEPS ) + errmesg("v_get_vars"); + v_copy(x,y); + n = v_resize_vars(10,&x,&y,&z,NULL); + if ( n != 3 || v_norm2(v_sub(x,y,z)) >= MACHEPS ) + errmesg("VEC copy/resize"); + + n = v_resize_vars(20,&x,&y,&z,NULL); + if ( n != 3 || v_norm2(v_sub(x,y,z)) >= MACHEPS ) + errmesg("VEC resize"); + + n = v_free_vars(&x,&y,&z,NULL); + if (n != 3) + errmesg("v_free_vars"); + + /* IVEC */ + notice("int vector initialise, copy & resize"); + n = iv_get_vars(15,&ix,&iy,&iz,NULL); + + if (n != 3) { + errmesg("iv_get_vars"); + printf(" n = %d (should be 3)\n",n); + } + for (i=0; i < ix->dim; i++) { + ix->ive[i] = 2*i-1; + iy->ive[i] = 3*i+2; + } + iz = iv_add(ix,iy,iz); + for (i=0; i < ix->dim; i++) + if ( iz->ive[i] != 5*i+1) + errmesg("iv_get_vars"); + + n = iv_resize_vars(10,&ix,&iy,&iz,NULL); + if ( n != 3) errmesg("IVEC copy/resize"); + + iv_add(ix,iy,iz); + for (i=0; i < ix->dim; i++) + if (iz->ive[i] != 5*i+1) + errmesg("IVEC copy/resize"); + + n = iv_resize_vars(20,&ix,&iy,&iz,NULL); + if ( n != 3 ) errmesg("IVEC resize"); + + iv_add(ix,iy,iz); + for (i=0; i < 10; i++) + if (iz->ive[i] != 5*i+1) + errmesg("IVEC copy/resize"); + + n = iv_free_vars(&ix,&iy,&iz,NULL); + if (n != 3) + errmesg("iv_free_vars"); + + /* MAT */ + notice("matrix initialise, copy & resize"); + n = m_get_vars(10,10,&A,&B,&C,NULL); + if (n != 3) { + errmesg("m_get_vars"); + printf(" n = %d (should be 3)\n",n); + } + + m_rand(A); + m_rand(B); + C = m_copy(A,C); + if ( m_norm_inf(m_sub(A,C,C)) >= MACHEPS ) + errmesg("MAT copy"); + m_copy(A,B); + n = m_resize_vars(5,5,&A,&B,&C,NULL); + if ( n != 3 || m_norm_inf(m_sub(A,B,C)) >= MACHEPS ) + errmesg("MAT copy/resize"); + + n = m_resize_vars(20,20,&A,&B,NULL); + if ( m_norm_inf(m_sub(A,B,C)) >= MACHEPS ) + errmesg("MAT resize"); + + k = m_free_vars(&A,&B,&C,NULL); + if ( k != 3 ) + errmesg("MAT free"); + + /* PERM */ + notice("permutation initialise, inverting & permuting vectors"); + n = px_get_vars(15,&pi1,&pi2,&pi3,NULL); + if (n != 3) { + errmesg("px_get_vars"); + printf(" n = %d (should be 3)\n",n); + } + + v_get_vars(15,&x,&y,&z,NULL); + + px_rand(pi1); + v_rand(x); + px_vec(pi1,x,z); + y = v_resize(y,x->dim); + pxinv_vec(pi1,z,y); + if ( v_norm2(v_sub(x,y,z)) >= MACHEPS ) + errmesg("PERMute vector"); + pi2 = px_inv(pi1,pi2); + pi3 = px_mlt(pi1,pi2,pi3); + for ( i = 0; i < pi3->size; i++ ) + if ( pi3->pe[i] != i ) + errmesg("PERM inverse/multiply"); + + px_resize_vars(20,&pi1,&pi2,&pi3,NULL); + v_resize_vars(20,&x,&y,&z,NULL); + + px_rand(pi1); + v_rand(x); + px_vec(pi1,x,z); + pxinv_vec(pi1,z,y); + if ( v_norm2(v_sub(x,y,z)) >= MACHEPS ) + errmesg("PERMute vector"); + pi2 = px_inv(pi1,pi2); + pi3 = px_mlt(pi1,pi2,pi3); + for ( i = 0; i < pi3->size; i++ ) + if ( pi3->pe[i] != i ) + errmesg("PERM inverse/multiply"); + + n = px_free_vars(&pi1,&pi2,&pi3,NULL); + if ( n != 3 ) + errmesg("PERM px_free_vars"); + +#ifdef SPARSE + /* set up two random sparse matrices */ + m = 120; + n = 100; + deg = 5; + notice("allocating sparse matrices"); + k = sp_get_vars(m,n,deg,&sA,&sB,NULL); + if (k != 2) { + errmesg("sp_get_vars"); + printf(" n = %d (should be 2)\n",k); + } + + notice("setting and getting matrix entries"); + for ( k = 0; k < m*deg; k++ ) + { + i = (rand() >> 8) % m; + j = (rand() >> 8) % n; + sp_set_val(sA,i,j,rand()/((Real)MAX_RAND)); + i = (rand() >> 8) % m; + j = (rand() >> 8) % n; + sp_set_val(sB,i,j,rand()/((Real)MAX_RAND)); + } + for ( k = 0; k < 10; k++ ) + { + s1 = rand()/((Real)MAX_RAND); + i = (rand() >> 8) % m; + j = (rand() >> 8) % n; + sp_set_val(sA,i,j,s1); + s2 = sp_get_val(sA,i,j); + if ( fabs(s1 - s2) >= MACHEPS ) { + printf(" s1 = %g, s2 = %g, |s1 - s2| = %g\n", + s1,s2,fabs(s1-s2)); + break; + } + } + if ( k < 10 ) + errmesg("sp_set_val()/sp_get_val()"); + + /* check column access paths */ + notice("resizing and access paths"); + k = sp_resize_vars(sA->m+10,sA->n+10,&sA,&sB,NULL); + if (k != 2) { + errmesg("sp_get_vars"); + printf(" n = %d (should be 2)\n",k); + } + + for ( k = 0 ; k < 20; k++ ) + { + i = sA->m - 1 - ((rand() >> 8) % 10); + j = sA->n - 1 - ((rand() >> 8) % 10); + s1 = rand()/((Real)MAX_RAND); + sp_set_val(sA,i,j,s1); + if ( fabs(s1 - sp_get_val(sA,i,j)) >= MACHEPS ) + break; + } + if ( k < 20 ) + errmesg("sp_resize()"); + sp_col_access(sA); + if ( ! chk_col_access(sA) ) + { + errmesg("sp_col_access()"); + } + sp_diag_access(sA); + for ( i = 0; i < sA->m; i++ ) + { + r = &(sA->row[i]); + if ( r->diag != sprow_idx(r,i) ) + break; + } + if ( i < sA->m ) + { + errmesg("sp_diag_access()"); + } + + k = sp_free_vars(&sA,&sB,NULL); + if (k != 2) + errmesg("sp_free_vars"); +#endif /* SPARSE */ + + +#ifdef COMPLEX + /* complex stuff */ + + ONE = zmake(1.0,0.0); + printf("# ONE = "); z_output(ONE); + printf("# Check: MACHEPS = %g\n",MACHEPS); + /* allocate, initialise, copy and resize operations */ + /* ZVEC */ + notice("vector initialise, copy & resize"); + zv_get_vars(12,&zx,&zy,&zz,NULL); + + zv_rand(zx); + zv_rand(zy); + zz = zv_copy(zx,zz); + if ( zv_norm2(zv_sub(zx,zz,zz)) >= MACHEPS ) + errmesg("ZVEC copy"); + zv_copy(zx,zy); + + zv_resize_vars(10,&zx,&zy,NULL); + if ( zv_norm2(zv_sub(zx,zy,zz)) >= MACHEPS ) + errmesg("ZVEC copy/resize"); + + zv_resize_vars(20,&zx,&zy,NULL); + if ( zv_norm2(zv_sub(zx,zy,zz)) >= MACHEPS ) + errmesg("VZEC resize"); + zv_free_vars(&zx,&zy,&zz,NULL); + + + /* ZMAT */ + notice("matrix initialise, copy & resize"); + zm_get_vars(8,5,&zA,&zB,&zC,NULL); + + zm_rand(zA); + zm_rand(zB); + zC = zm_copy(zA,zC); + if ( zm_norm_inf(zm_sub(zA,zC,zC)) >= MACHEPS ) + errmesg("ZMAT copy"); + + zm_copy(zA,zB); + zm_resize_vars(3,5,&zA,&zB,&zC,NULL); + + if ( zm_norm_inf(zm_sub(zA,zB,zC)) >= MACHEPS ) + errmesg("ZMAT copy/resize"); + zm_resize_vars(20,20,&zA,&zB,&zC,NULL); + + if ( zm_norm_inf(zm_sub(zA,zB,zC)) >= MACHEPS ) + errmesg("ZMAT resize"); + + zm_free_vars(&zA,&zB,&zC,NULL); +#endif /* COMPLEX */ + +#endif /* if defined(ANSI_C) || defined(VARARGS) */ + + printf("# test of mem_info_bytes and mem_info_numvar\n"); + printf(" TYPE VEC: %ld bytes allocated, %d variables allocated\n", + mem_info_bytes(TYPE_VEC,0),mem_info_numvar(TYPE_VEC,0)); + + notice("static memory test"); + mem_info_on(TRUE); + mem_stat_mark(1); + for (i=0; i < 100; i++) + stat_test1(i); + mem_stat_free(1); + + mem_stat_mark(1); + for (i=0; i < 100; i++) { + stat_test1(i); +#ifdef COMPLEX + stat_test4(i); +#endif + } + + mem_stat_mark(2); + for (i=0; i < 100; i++) + stat_test2(i); + + mem_stat_mark(3); +#ifdef SPARSE + for (i=0; i < 100; i++) + stat_test3(i); +#endif + + mem_info(); + mem_dump_list(stdout,0); + + mem_stat_free(1); + mem_stat_free(3); + mem_stat_mark(4); + + for (i=0; i < 100; i++) { + stat_test1(i); +#ifdef COMPLEX + stat_test4(i); +#endif + } + + mem_stat_dump(stdout,0); + if (mem_stat_show_mark() != 4) { + errmesg("not 4 in mem_stat_show_mark()"); + } + + mem_stat_free(2); + mem_stat_free(4); + + if (mem_stat_show_mark() != 0) { + errmesg("not 0 in mem_stat_show_mark()"); + } + + /* add new list of types */ + + mem_attach_list(FOO_LIST,FOO_NUM_TYPES,foo_type_name, + foo_free_func,foo_info_sum); + if (!mem_is_list_attached(FOO_LIST)) + errmesg("list FOO_LIST is not attached"); + + mem_dump_list(stdout,FOO_LIST); + foo_1 = foo_1_get(6); + foo_2 = foo_2_get(3); + for (i=0; i < foo_1->dim; i++) + for (j=0; j < foo_1->fix_dim; j++) + foo_1->a[i][j] = i+j; + for (i=0; i < foo_2->dim; i++) + for (j=0; j < foo_2->fix_dim; j++) + foo_2->a[i][j] = i+j; + printf(" foo_1->a[%d][%d] = %g\n",5,9,foo_1->a[5][9]); + printf(" foo_2->a[%d][%d] = %g\n",2,1,foo_2->a[2][1]); + + mem_stat_mark(5); + mem_stat_reg_list((void **)&foo_1,TYPE_FOO_1,FOO_LIST); + mem_stat_reg_list((void **)&foo_2,TYPE_FOO_2,FOO_LIST); + mem_stat_dump(stdout,FOO_LIST); + mem_info_file(stdout,FOO_LIST); + mem_stat_free_list(5,FOO_LIST); + mem_stat_dump(stdout,FOO_LIST); + if ( foo_1 != NULL ) + errmesg(" foo_1 is not released"); + if ( foo_2 != NULL ) + errmesg(" foo_2 is not released"); + mem_dump_list(stdout,FOO_LIST); + mem_info_file(stdout,FOO_LIST); + + mem_free_vars(FOO_LIST); + if ( mem_is_list_attached(FOO_LIST) ) + errmesg("list FOO_LIST is not detached"); + + mem_info(); + +#if REAL == FLOAT + printf("# SINGLE PRECISION was used\n"); +#elif REAL == DOUBLE + printf("# DOUBLE PRECISION was used\n"); +#endif + +#define ANSI_OR_VAR + +#ifndef ANSI_C +#ifndef VARARGS +#undef ANSI_OR_VAR +#endif +#endif + +#ifdef ANSI_OR_VAR + + printf("# you should get: \n"); +#if (REAL == FLOAT) + printf("# type VEC: 276 bytes allocated, 3 variables allocated\n"); +#elif (REAL == DOUBLE) + printf("# type VEC: 516 bytes allocated, 3 variables allocated\n"); +#endif + printf("# and other types are zeros\n"); + +#endif /*#if defined(ANSI_C) || defined(VARAGS) */ + + printf("# Finished memory torture test\n"); + return; +} diff --git a/meschach/mfunc.c b/meschach/mfunc.c new file mode 100644 index 0000000..6d21ae6 --- /dev/null +++ b/meschach/mfunc.c @@ -0,0 +1,391 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + This file contains routines for computing functions of matrices + especially polynomials and exponential functions + Copyright (C) Teresa Leyk and David Stewart, 1993 + */ + +#include +#include +#include "matrix.h" +#include "matrix2.h" + +static char rcsid[] = "$Id: mfunc.c,v 1.1 2001/03/01 17:18:54 rfranke Exp $"; + + + +/* _m_pow -- computes integer powers of a square matrix A, A^p + -- uses tmp as temporary workspace */ +MAT *_m_pow(A, p, tmp, out) +MAT *A, *tmp, *out; +int p; +{ + int it_cnt, k, max_bit; + + /* + File containing routines for evaluating matrix functions + esp. the exponential function + */ + +#define Z(k) (((k) & 1) ? tmp : out) + + if ( ! A ) + error(E_NULL,"_m_pow"); + if ( A->m != A->n ) + error(E_SQUARE,"_m_pow"); + if ( p < 0 ) + error(E_NEG,"_m_pow"); + out = m_resize(out,A->m,A->n); + tmp = m_resize(tmp,A->m,A->n); + + if ( p == 0 ) + m_ident(out); + else if ( p > 0 ) + { + it_cnt = 1; + for ( max_bit = 0; ; max_bit++ ) + if ( (p >> (max_bit+1)) == 0 ) + break; + tmp = m_copy(A,tmp); + + for ( k = 0; k < max_bit; k++ ) + { + m_mlt(Z(it_cnt),Z(it_cnt),Z(it_cnt+1)); + it_cnt++; + if ( p & (1 << (max_bit-1)) ) + { + m_mlt(A,Z(it_cnt),Z(it_cnt+1)); + /* m_copy(Z(it_cnt),out); */ + it_cnt++; + } + p <<= 1; + } + if (it_cnt & 1) + out = m_copy(Z(it_cnt),out); + } + + return out; + +#undef Z +} + +/* m_pow -- computes integer powers of a square matrix A, A^p */ +MAT *m_pow(A, p, out) +MAT *A, *out; +int p; +{ + static MAT *wkspace = MNULL; + + if ( ! A ) + error(E_NULL,"m_pow"); + if ( A->m != A->n ) + error(E_SQUARE,"m_pow"); + + wkspace = m_resize(wkspace,A->m,A->n); + MEM_STAT_REG(wkspace,TYPE_MAT); + + return _m_pow(A, p, wkspace, out); + +} + +/**************************************************/ + +/* _m_exp -- compute matrix exponential of A and save it in out + -- uses Pade approximation followed by repeated squaring + -- eps is the tolerance used for the Pade approximation + -- A is not changed + -- q_out - degree of the Pade approximation (q_out,q_out) + -- j_out - the power of 2 for scaling the matrix A + such that ||A/2^j_out|| <= 0.5 +*/ +MAT *_m_exp(A,eps,out,q_out,j_out) +MAT *A,*out; +double eps; +int *q_out, *j_out; +{ + static MAT *D = MNULL, *Apow = MNULL, *N = MNULL, *Y = MNULL; + static VEC *c1 = VNULL, *tmp = VNULL; + VEC y0, y1; /* additional structures */ + static PERM *pivot = PNULL; + int j, k, l, q, r, s, j2max, t; + double inf_norm, eqq, power2, c, sign; + + if ( ! A ) + error(E_SIZES,"_m_exp"); + if ( A->m != A->n ) + error(E_SIZES,"_m_exp"); + if ( A == out ) + error(E_INSITU,"_m_exp"); + if ( eps < 0.0 ) + error(E_RANGE,"_m_exp"); + else if (eps == 0.0) + eps = MACHEPS; + + N = m_resize(N,A->m,A->n); + D = m_resize(D,A->m,A->n); + Apow = m_resize(Apow,A->m,A->n); + out = m_resize(out,A->m,A->n); + + MEM_STAT_REG(N,TYPE_MAT); + MEM_STAT_REG(D,TYPE_MAT); + MEM_STAT_REG(Apow,TYPE_MAT); + + /* normalise A to have ||A||_inf <= 1 */ + inf_norm = m_norm_inf(A); + if (inf_norm <= 0.0) { + m_ident(out); + *q_out = -1; + *j_out = 0; + return out; + } + else { + j2max = floor(1+log(inf_norm)/log(2.0)); + j2max = max(0, j2max); + } + + power2 = 1.0; + for ( k = 1; k <= j2max; k++ ) + power2 *= 2; + power2 = 1.0/power2; + if ( j2max > 0 ) + sm_mlt(power2,A,A); + + /* compute order for polynomial approximation */ + eqq = 1.0/6.0; + for ( q = 1; eqq > eps; q++ ) + eqq /= 16.0*(2.0*q+1.0)*(2.0*q+3.0); + + /* construct vector of coefficients */ + c1 = v_resize(c1,q+1); + MEM_STAT_REG(c1,TYPE_VEC); + c1->ve[0] = 1.0; + for ( k = 1; k <= q; k++ ) + c1->ve[k] = c1->ve[k-1]*(q-k+1)/((2*q-k+1)*(double)k); + + tmp = v_resize(tmp,A->n); + MEM_STAT_REG(tmp,TYPE_VEC); + + s = (int)floor(sqrt((double)q/2.0)); + if ( s <= 0 ) s = 1; + _m_pow(A,s,out,Apow); + r = q/s; + + Y = m_resize(Y,s,A->n); + MEM_STAT_REG(Y,TYPE_MAT); + /* y0 and y1 are pointers to rows of Y, N and D */ + y0.dim = y0.max_dim = A->n; + y1.dim = y1.max_dim = A->n; + + m_zero(Y); + m_zero(N); + m_zero(D); + + for( j = 0; j < A->n; j++ ) + { + if (j > 0) + Y->me[0][j-1] = 0.0; + y0.ve = Y->me[0]; + y0.ve[j] = 1.0; + for ( k = 0; k < s-1; k++ ) + { + y1.ve = Y->me[k+1]; + mv_mlt(A,&y0,&y1); + y0.ve = y1.ve; + } + + y0.ve = N->me[j]; + y1.ve = D->me[j]; + t = s*r; + for ( l = 0; l <= q-t; l++ ) + { + c = c1->ve[t+l]; + sign = ((t+l) & 1) ? -1.0 : 1.0; + __mltadd__(y0.ve,Y->me[l],c, Y->n); + __mltadd__(y1.ve,Y->me[l],c*sign,Y->n); + } + + for (k=1; k <= r; k++) + { + v_copy(mv_mlt(Apow,&y0,tmp),&y0); + v_copy(mv_mlt(Apow,&y1,tmp),&y1); + t = s*(r-k); + for (l=0; l < s; l++) + { + c = c1->ve[t+l]; + sign = ((t+l) & 1) ? -1.0 : 1.0; + __mltadd__(y0.ve,Y->me[l],c, Y->n); + __mltadd__(y1.ve,Y->me[l],c*sign,Y->n); + } + } + } + + pivot = px_resize(pivot,A->m); + MEM_STAT_REG(pivot,TYPE_PERM); + + /* note that N and D are transposed, + therefore we use LUTsolve; + out is saved row-wise, and must be transposed + after this */ + + LUfactor(D,pivot); + for (k=0; k < A->n; k++) + { + y0.ve = N->me[k]; + y1.ve = out->me[k]; + LUTsolve(D,pivot,&y0,&y1); + } + m_transp(out,out); + + + /* Use recursive squaring to turn the normalised exponential to the + true exponential */ + +#define Z(k) ((k) & 1 ? Apow : out) + + for( k = 1; k <= j2max; k++) + m_mlt(Z(k-1),Z(k-1),Z(k)); + + if (Z(k) == out) + m_copy(Apow,out); + + /* output parameters */ + *j_out = j2max; + *q_out = q; + + /* restore the matrix A */ + sm_mlt(1.0/power2,A,A); + return out; + +#undef Z +} + + +/* simple interface for _m_exp */ +MAT *m_exp(A,eps,out) +MAT *A,*out; +double eps; +{ + int q_out, j_out; + + return _m_exp(A,eps,out,&q_out,&j_out); +} + + +/*--------------------------------*/ + +/* m_poly -- computes sum_i a[i].A^i, where i=0,1,...dim(a); + -- uses C. Van Loan's fast and memory efficient method */ +MAT *m_poly(A,a,out) +MAT *A,*out; +VEC *a; +{ + static MAT *Apow = MNULL, *Y = MNULL; + static VEC *tmp; + VEC y0, y1; /* additional vectors */ + int j, k, l, q, r, s, t; + + if ( ! A || ! a ) + error(E_NULL,"m_poly"); + if ( A->m != A->n ) + error(E_SIZES,"m_poly"); + if ( A == out ) + error(E_INSITU,"m_poly"); + + out = m_resize(out,A->m,A->n); + Apow = m_resize(Apow,A->m,A->n); + MEM_STAT_REG(Apow,TYPE_MAT); + tmp = v_resize(tmp,A->n); + MEM_STAT_REG(tmp,TYPE_VEC); + + q = a->dim - 1; + if ( q == 0 ) { + m_zero(out); + for (j=0; j < out->n; j++) + out->me[j][j] = a->ve[0]; + return out; + } + else if ( q == 1) { + sm_mlt(a->ve[1],A,out); + for (j=0; j < out->n; j++) + out->me[j][j] += a->ve[0]; + return out; + } + + s = (int)floor(sqrt((double)q/2.0)); + if ( s <= 0 ) s = 1; + _m_pow(A,s,out,Apow); + r = q/s; + + Y = m_resize(Y,s,A->n); + MEM_STAT_REG(Y,TYPE_MAT); + /* pointers to rows of Y */ + y0.dim = y0.max_dim = A->n; + y1.dim = y1.max_dim = A->n; + + m_zero(Y); + m_zero(out); + +#define Z(k) ((k) & 1 ? tmp : &y0) +#define ZZ(k) ((k) & 1 ? tmp->ve : y0.ve) + + for( j = 0; j < A->n; j++) + { + if( j > 0 ) + Y->me[0][j-1] = 0.0; + Y->me[0][j] = 1.0; + + y0.ve = Y->me[0]; + for (k = 0; k < s-1; k++) + { + y1.ve = Y->me[k+1]; + mv_mlt(A,&y0,&y1); + y0.ve = y1.ve; + } + + y0.ve = out->me[j]; + + t = s*r; + for ( l = 0; l <= q-t; l++ ) + __mltadd__(y0.ve,Y->me[l],a->ve[t+l],Y->n); + + for (k=1; k <= r; k++) + { + mv_mlt(Apow,Z(k-1),Z(k)); + t = s*(r-k); + for (l=0; l < s; l++) + __mltadd__(ZZ(k),Y->me[l],a->ve[t+l],Y->n); + } + if (Z(k) == &y0) v_copy(tmp,&y0); + } + + m_transp(out,out); + + return out; +} + + diff --git a/meschach/mfuntort.c b/meschach/mfuntort.c new file mode 100644 index 0000000..f50a06f --- /dev/null +++ b/meschach/mfuntort.c @@ -0,0 +1,181 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* mfuntort.c, 10/11/93 */ + +static char rcsid[] = "$Id: mfuntort.c,v 1.1 2001/03/01 17:18:54 rfranke Exp $"; + +#include +#include +#include "matrix.h" +#include "matrix2.h" + + +#define errmesg(mesg) printf("Error: %s error: line %d\n",mesg,__LINE__) +#define notice(mesg) printf("# Testing %s...\n",mesg); + +#define DIM 10 + +void main() +{ + + MAT *A, *B, *C, *OUTA, *OUTB, *TMP; + MAT *exp_A_expected, *exp_A; + VEC *x, *b; + double c, eps = 1e-10; + int i, j, q_out, j_out; + + mem_info_on(TRUE); + + A = m_get(DIM,DIM); + B = m_get(DIM,DIM); + C = m_get(DIM,DIM); + OUTA = m_get(DIM,DIM); + OUTB = m_get(DIM,DIM); + TMP = m_get(DIM,DIM); + x = v_get(DIM); + b = v_get(6); + + notice("exponent of a matrix"); + + m_ident(A); + mem_stat_mark(1); + _m_exp(A,eps,OUTA,&q_out,&j_out); + printf("# q_out = %d, j_out = %d\n",q_out,j_out); + + m_exp(A,eps,OUTA); + sm_mlt(exp(1.0),A,A); + m_sub(OUTA,A,TMP); + printf("# ||exp(I) - e*I|| = %g\n",m_norm_inf(TMP)); + + m_rand(A); + m_transp(A,TMP); + m_add(A,TMP,A); + B = m_copy(A,B); + + m_exp(A,eps,OUTA); + + symmeig(B,OUTB,x); + m_zero(TMP); + for (i=0; i < x->dim; i++) + TMP->me[i][i] = exp(x->ve[i]); + m_mlt(OUTB,TMP,C); + mmtr_mlt(C,OUTB,TMP); + m_sub(TMP,OUTA,TMP); + printf("# ||exp(A) - Q*exp(lambda)*Q^T|| = %g\n",m_norm_inf(TMP)); + + notice("polynomial of a matrix"); + m_rand(A); + m_transp(A,TMP); + m_add(A,TMP,A); + B = m_copy(A,B); + v_rand(b); + + m_poly(A,b,OUTA); + + symmeig(B,OUTB,x); + m_zero(TMP); + for (i=0; i < x->dim; i++) { + c = b->ve[b->dim-1]; + for (j=b->dim-2; j >= 0; j--) + c = c*x->ve[i] + b->ve[j]; + TMP->me[i][i] = c; + } + m_mlt(OUTB,TMP,C); + mmtr_mlt(C,OUTB,TMP); + m_sub(TMP,OUTA,TMP); + printf("# ||poly(A) - Q*poly(lambda)*Q^T|| = %g\n",m_norm_inf(TMP)); + mem_stat_free(1); + + + /* Brook Milligan's test */ + + M_FREE(A); + M_FREE(B); + M_FREE(C); + + notice("exponent of a nonsymmetric matrix"); + A = m_get (2, 2); + A -> me [0][0] = 1.0; + A -> me [0][1] = 1.0; + A -> me [1][0] = 4.0; + A -> me [1][1] = 1.0; + + exp_A_expected = m_get(2, 2); + exp_A_expected -> me [0][0] = exp (3.0) / 2.0 + exp (-1.0) / 2.0; + exp_A_expected -> me [0][1] = exp (3.0) / 4.0 - exp (-1.0) / 4.0; + exp_A_expected -> me [1][0] = exp (3.0) - exp (-1.0); + exp_A_expected -> me [1][1] = exp (3.0) / 2.0 + exp (-1.0) / 2.0; + + printf ("A:\n"); + for (i = 0; i < 2; i++) + { + for (j = 0; j < 2; j++) + printf (" %15.8e", A -> me [i][j]); + printf ("\n"); + } + + printf ("\nexp(A) (expected):\n"); + for (i = 0; i < 2; i++) + { + for (j = 0; j < 2; j++) + printf (" %15.8e", exp_A_expected -> me [i][j]); + printf ("\n"); + } + + mem_stat_mark(3); + exp_A = m_exp (A, 1e-16,NULL); + mem_stat_free(3); + + printf ("\nexp(A):\n"); + for (i = 0; i < 2; i++) + { + for (j = 0; j < 2; j++) + printf (" %15.8e", exp_A -> me [i][j]); + printf ("\n"); + } + printf ("\nexp(A) - exp(A) (expected):\n"); + for (i = 0; i < 2; i++) + { + for (j = 0; j < 2; j++) + printf (" %15.8e", exp_A -> me [i][j] - exp_A_expected -> me [i][j]); + printf ("\n"); + } + + M_FREE(A); + M_FREE(B); + M_FREE(C); + M_FREE(exp_A); + M_FREE(exp_A_expected); + M_FREE(OUTA); + M_FREE(OUTB); + M_FREE(TMP); + V_FREE(b); + V_FREE(x); + + mem_info(); +} + diff --git a/meschach/norm.c b/meschach/norm.c new file mode 100644 index 0000000..c4b9b64 --- /dev/null +++ b/meschach/norm.c @@ -0,0 +1,200 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + A collection of functions for computing norms: scaled and unscaled +*/ +static char rcsid[] = "$Id: norm.c,v 1.1 2001/03/01 17:18:55 rfranke Exp $"; + +#include +#include +#include "matrix.h" + + +/* _v_norm1 -- computes (scaled) 1-norms of vectors */ +double _v_norm1(x,scale) +VEC *x, *scale; +{ + int i, dim; + Real s, sum; + + if ( x == (VEC *)NULL ) + error(E_NULL,"_v_norm1"); + dim = x->dim; + + sum = 0.0; + if ( scale == (VEC *)NULL ) + for ( i = 0; i < dim; i++ ) + sum += fabs(x->ve[i]); + else if ( scale->dim < dim ) + error(E_SIZES,"_v_norm1"); + else + for ( i = 0; i < dim; i++ ) + { s = scale->ve[i]; + sum += ( s== 0.0 ) ? fabs(x->ve[i]) : fabs(x->ve[i]/s); + } + + return sum; +} + +/* square -- returns x^2 */ +double square(x) +double x; +{ return x*x; } + +#if 0 +/* cube -- returns x^3 */ +double cube(x) +double x; +{ return x*x*x; } +#endif + +/* _v_norm2 -- computes (scaled) 2-norm (Euclidean norm) of vectors */ +double _v_norm2(x,scale) +VEC *x, *scale; +{ + int i, dim; + Real s, sum; + + if ( x == (VEC *)NULL ) + error(E_NULL,"_v_norm2"); + dim = x->dim; + + sum = 0.0; + if ( scale == (VEC *)NULL ) + for ( i = 0; i < dim; i++ ) + sum += square(x->ve[i]); + else if ( scale->dim < dim ) + error(E_SIZES,"_v_norm2"); + else + for ( i = 0; i < dim; i++ ) + { s = scale->ve[i]; + sum += ( s== 0.0 ) ? square(x->ve[i]) : + square(x->ve[i]/s); + } + + return sqrt(sum); +} + +#define max(a,b) ((a) > (b) ? (a) : (b)) + +/* _v_norm_inf -- computes (scaled) infinity-norm (supremum norm) of vectors */ +double _v_norm_inf(x,scale) +VEC *x, *scale; +{ + int i, dim; + Real s, maxval, tmp; + + if ( x == (VEC *)NULL ) + error(E_NULL,"_v_norm_inf"); + dim = x->dim; + + maxval = 0.0; + if ( scale == (VEC *)NULL ) + for ( i = 0; i < dim; i++ ) + { tmp = fabs(x->ve[i]); + maxval = max(maxval,tmp); + } + else if ( scale->dim < dim ) + error(E_SIZES,"_v_norm_inf"); + else + for ( i = 0; i < dim; i++ ) + { s = scale->ve[i]; + tmp = ( s== 0.0 ) ? fabs(x->ve[i]) : fabs(x->ve[i]/s); + maxval = max(maxval,tmp); + } + + return maxval; +} + +/* m_norm1 -- compute matrix 1-norm -- unscaled */ +double m_norm1(A) +MAT *A; +{ + int i, j, m, n; + Real maxval, sum; + + if ( A == (MAT *)NULL ) + error(E_NULL,"m_norm1"); + + m = A->m; n = A->n; + maxval = 0.0; + + for ( j = 0; j < n; j++ ) + { + sum = 0.0; + for ( i = 0; i < m; i ++ ) + sum += fabs(A->me[i][j]); + maxval = max(maxval,sum); + } + + return maxval; +} + +/* m_norm_inf -- compute matrix infinity-norm -- unscaled */ +double m_norm_inf(A) +MAT *A; +{ + int i, j, m, n; + Real maxval, sum; + + if ( A == (MAT *)NULL ) + error(E_NULL,"m_norm_inf"); + + m = A->m; n = A->n; + maxval = 0.0; + + for ( i = 0; i < m; i++ ) + { + sum = 0.0; + for ( j = 0; j < n; j ++ ) + sum += fabs(A->me[i][j]); + maxval = max(maxval,sum); + } + + return maxval; +} + +/* m_norm_frob -- compute matrix frobenius-norm -- unscaled */ +double m_norm_frob(A) +MAT *A; +{ + int i, j, m, n; + Real sum; + + if ( A == (MAT *)NULL ) + error(E_NULL,"m_norm_frob"); + + m = A->m; n = A->n; + sum = 0.0; + + for ( i = 0; i < m; i++ ) + for ( j = 0; j < n; j ++ ) + sum += square(A->me[i][j]); + + return sqrt(sum); +} + diff --git a/meschach/oldnames.h b/meschach/oldnames.h new file mode 100644 index 0000000..d014d53 --- /dev/null +++ b/meschach/oldnames.h @@ -0,0 +1,150 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* macros for names used in versions 1.0 and 1.1 */ +/* 8/11/93 */ + + +#ifndef OLDNAMESH +#define OLDNAMESH + + +/* type IVEC */ + +#define get_ivec iv_get +#define freeivec IV_FREE +#define cp_ivec iv_copy +#define fout_ivec iv_foutput +#define out_ivec iv_output +#define fin_ivec iv_finput +#define in_ivec iv_input +#define dump_ivec iv_dump + + +/* type ZVEC */ + +#define get_zvec zv_get +#define freezvec ZV_FREE +#define cp_zvec zv_copy +#define fout_zvec zv_foutput +#define out_zvec zv_output +#define fin_zvec zv_finput +#define in_zvec zv_input +#define zero_zvec zv_zero +#define rand_zvec zv_rand +#define dump_zvec zv_dump + +/* type ZMAT */ + +#define get_zmat zm_get +#define freezmat ZM_FREE +#define cp_zmat zm_copy +#define fout_zmat zm_foutput +#define out_zmat zm_output +#define fin_zmat zm_finput +#define in_zmat zm_input +#define zero_zmat zm_zero +#define rand_zmat zm_rand +#define dump_zmat zm_dump + +/* types SPMAT */ + +#define sp_mat SPMAT +#define sp_get_mat sp_get +#define sp_free_mat sp_free +#define sp_cp_mat sp_copy +#define sp_cp_mat2 sp_copy2 +#define sp_fout_mat sp_foutput +#define sp_fout_mat2 sp_foutput2 +#define sp_out_mat sp_output +#define sp_out_mat2 sp_output2 +#define sp_fin_mat sp_finput +#define sp_in_mat sp_input +#define sp_zero_mat sp_zero +#define sp_dump_mat sp_dump + + +/* type SPROW */ + +#define sp_row SPROW +#define sp_get_idx sprow_idx +#define row_xpd sprow_xpd +#define sp_get_row sprow_get +#define row_set_val sprow_set_val +#define fout_row sprow_foutput +#define _row_mltadd sprow_mltadd +#define sp_row_copy sprow_copy +#define sp_row_merge sprow_merge +#define sp_row_ip sprow_ip +#define sp_row_sqr sprow_sqr + + +/* type MAT */ + +#define get_mat m_get +#define freemat M_FREE +#define cp_mat m_copy +#define fout_mat m_foutput +#define out_mat m_output +#define fin_mat m_finput +#define in_mat m_input +#define zero_mat m_zero +#define id_mat m_ident +#define rand_mat m_rand +#define ones_mat m_ones +#define dump_mat m_dump + +/* type VEC */ + +#define get_vec v_get +#define freevec V_FREE +#define cp_vec v_copy +#define fout_vec v_foutput +#define out_vec v_output +#define fin_vec v_finput +#define in_vec v_input +#define zero_vec v_zero +#define rand_vec v_rand +#define ones_vec v_ones +#define dump_vec v_dump + + +/* type PERM */ + +#define get_perm px_get +#define freeperm PX_FREE +#define cp_perm px_copy +#define fout_perm px_foutput +#define out_perm px_output +#define fin_perm px_finput +#define in_perm px_input +#define id_perm px_ident +#define px_id px_ident +#define trans_px px_transp +#define sign_px px_sign +#define dump_perm px_dump + +#endif diff --git a/meschach/otherio.c b/meschach/otherio.c new file mode 100644 index 0000000..0cc2d99 --- /dev/null +++ b/meschach/otherio.c @@ -0,0 +1,164 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + File for doing assorted I/O operations not invlolving + MAT/VEC/PERM objects +*/ +static char rcsid[] = "$Id: otherio.c,v 1.1 2001/03/01 17:18:55 rfranke Exp $"; + +#include +#include +#include "matrix.h" + + + +/* scratch area -- enough for a single line */ +static char scratch[MAXLINE+1]; + +/* default value for fy_or_n */ +static int y_n_dflt = TRUE; + +/* fy_or_n -- yes-or-no to question is string s + -- question written to stderr, input from fp + -- if fp is NOT a tty then return y_n_dflt */ +int fy_or_n(fp,s) +FILE *fp; +char *s; +{ + char *cp; + + if ( ! isatty(fileno(fp)) ) + return y_n_dflt; + + for ( ; ; ) + { + fprintf(stderr,"%s (y/n) ? ",s); + if ( fgets(scratch,MAXLINE,fp)==NULL ) + error(E_INPUT,"fy_or_n"); + cp = scratch; + while ( isspace(*cp) ) + cp++; + if ( *cp == 'y' || *cp == 'Y' ) + return TRUE; + if ( *cp == 'n' || *cp == 'N' ) + return FALSE; + fprintf(stderr,"Please reply with 'y' or 'Y' for yes "); + fprintf(stderr,"and 'n' or 'N' for no.\n"); + } +} + +/* yn_dflt -- sets the value of y_n_dflt to val */ +int yn_dflt(val) +int val; +{ return y_n_dflt = val; } + +/* fin_int -- return integer read from file/stream fp + -- prompt s on stderr if fp is a tty + -- check that x lies between low and high: re-prompt if + fp is a tty, error exit otherwise + -- ignore check if low > high */ +int fin_int(fp,s,low,high) +FILE *fp; +char *s; +int low, high; +{ + int retcode, x; + + if ( ! isatty(fileno(fp)) ) + { + skipjunk(fp); + if ( (retcode=fscanf(fp,"%d",&x)) == EOF ) + error(E_INPUT,"fin_int"); + if ( retcode <= 0 ) + error(E_FORMAT,"fin_int"); + if ( low <= high && ( x < low || x > high ) ) + error(E_BOUNDS,"fin_int"); + return x; + } + + for ( ; ; ) + { + fprintf(stderr,"%s: ",s); + if ( fgets(scratch,MAXLINE,stdin)==NULL ) + error(E_INPUT,"fin_int"); + retcode = sscanf(scratch,"%d",&x); + if ( ( retcode==1 && low > high ) || + ( x >= low && x <= high ) ) + return x; + fprintf(stderr,"Please type an integer in range [%d,%d].\n", + low,high); + } +} + + +/* fin_double -- return double read from file/stream fp + -- prompt s on stderr if fp is a tty + -- check that x lies between low and high: re-prompt if + fp is a tty, error exit otherwise + -- ignore check if low > high */ +double fin_double(fp,s,low,high) +FILE *fp; +char *s; +double low, high; +{ + Real retcode, x; + + if ( ! isatty(fileno(fp)) ) + { + skipjunk(fp); +#if REAL == DOUBLE + if ( (retcode=fscanf(fp,"%lf",&x)) == EOF ) +#elif REAL == FLOAT + if ( (retcode=fscanf(fp,"%f",&x)) == EOF ) +#endif + error(E_INPUT,"fin_double"); + if ( retcode <= 0 ) + error(E_FORMAT,"fin_double"); + if ( low <= high && ( x < low || x > high ) ) + error(E_BOUNDS,"fin_double"); + return (double)x; + } + + for ( ; ; ) + { + fprintf(stderr,"%s: ",s); + if ( fgets(scratch,MAXLINE,stdin)==NULL ) + error(E_INPUT,"fin_double"); +#if REAL == DOUBLE + retcode = sscanf(scratch,"%lf",&x); +#elif REAL == FLOAT + retcode = sscanf(scratch,"%f",&x); +#endif + if ( ( retcode==1 && low > high ) || + ( x >= low && x <= high ) ) + return (double)x; + fprintf(stderr,"Please type an double in range [%g,%g].\n", + low,high); + } +} + + diff --git a/meschach/pxop.c b/meschach/pxop.c new file mode 100644 index 0000000..346d9fb --- /dev/null +++ b/meschach/pxop.c @@ -0,0 +1,357 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* pxop.c 1.5 12/03/87 */ + + +#include +#include "matrix.h" + +static char rcsid[] = "$Id: pxop.c,v 1.1 2001/03/01 17:18:55 rfranke Exp $"; + +/********************************************************************** +Note: A permutation is often interpreted as a matrix + (i.e. a permutation matrix). + A permutation px represents a permutation matrix P where + P[i][j] == 1 if and only if px->pe[i] == j +**********************************************************************/ + + +/* px_inv -- invert permutation -- in situ + -- taken from ACM Collected Algorithms #250 */ +PERM *px_inv(px,out) +PERM *px, *out; +{ + int i, j, k, n, *p; + + out = px_copy(px, out); + n = out->size; + p = (int *)(out->pe); + for ( n--; n>=0; n-- ) + { + i = p[n]; + if ( i < 0 ) p[n] = -1 - i; + else if ( i != n ) + { + k = n; + while (TRUE) + { + if ( i < 0 || i >= out->size ) + error(E_BOUNDS,"px_inv"); + j = p[i]; p[i] = -1 - k; + if ( j == n ) + { p[n] = i; break; } + k = i; i = j; + } + } + } + return out; +} + +/* px_mlt -- permutation multiplication (composition) */ +PERM *px_mlt(px1,px2,out) +PERM *px1,*px2,*out; +{ + u_int i,size; + + if ( px1==(PERM *)NULL || px2==(PERM *)NULL ) + error(E_NULL,"px_mlt"); + if ( px1->size != px2->size ) + error(E_SIZES,"px_mlt"); + if ( px1 == out || px2 == out ) + error(E_INSITU,"px_mlt"); + if ( out==(PERM *)NULL || out->size < px1->size ) + out = px_resize(out,px1->size); + + size = px1->size; + for ( i=0; ipe[i] >= size ) + error(E_BOUNDS,"px_mlt"); + else + out->pe[i] = px1->pe[px2->pe[i]]; + + return out; +} + +/* px_vec -- permute vector */ +VEC *px_vec(px,vector,out) +PERM *px; +VEC *vector,*out; +{ + u_int old_i, i, size, start; + Real tmp; + + if ( px==(PERM *)NULL || vector==(VEC *)NULL ) + error(E_NULL,"px_vec"); + if ( px->size > vector->dim ) + error(E_SIZES,"px_vec"); + if ( out==(VEC *)NULL || out->dim < vector->dim ) + out = v_resize(out,vector->dim); + + size = px->size; + if ( size == 0 ) + return v_copy(vector,out); + if ( out != vector ) + { + for ( i=0; ipe[i] >= size ) + error(E_BOUNDS,"px_vec"); + else + out->ve[i] = vector->ve[px->pe[i]]; + } + else + { /* in situ algorithm */ + start = 0; + while ( start < size ) + { + old_i = start; + i = px->pe[old_i]; + if ( i >= size ) + { + start++; + continue; + } + tmp = vector->ve[start]; + while ( TRUE ) + { + vector->ve[old_i] = vector->ve[i]; + px->pe[old_i] = i+size; + old_i = i; + i = px->pe[old_i]; + if ( i >= size ) + break; + if ( i == start ) + { + vector->ve[old_i] = tmp; + px->pe[old_i] = i+size; + break; + } + } + start++; + } + + for ( i = 0; i < size; i++ ) + if ( px->pe[i] < size ) + error(E_BOUNDS,"px_vec"); + else + px->pe[i] = px->pe[i]-size; + } + + return out; +} +#if 0 +/* pxinv_vec -- apply the inverse of px to x, returning the result in out */ +VEC *pxinv_vec(px,x,out) +PERM *px; +VEC *x, *out; +{ + u_int i, size; + + if ( ! px || ! x ) + error(E_NULL,"pxinv_vec"); + if ( px->size > x->dim ) + error(E_SIZES,"pxinv_vec"); + /* if ( x == out ) + error(E_INSITU,"pxinv_vec"); */ + if ( ! out || out->dim < x->dim ) + out = v_resize(out,x->dim); + + size = px->size; + if ( size == 0 ) + return v_copy(x,out); + if ( out != x ) + { + for ( i=0; ipe[i] >= size ) + error(E_BOUNDS,"pxinv_vec"); + else + out->ve[px->pe[i]] = x->ve[i]; + } + else + { /* in situ algorithm --- cheat's way out */ + px_inv(px,px); + px_vec(px,x,out); + px_inv(px,px); + } + + return out; +} +#endif + + +/* px_transp -- transpose elements of permutation + -- Really multiplying a permutation by a transposition */ +PERM *px_transp(px,i1,i2) +PERM *px; /* permutation to transpose */ +u_int i1,i2; /* elements to transpose */ +{ + u_int temp; + + if ( px==(PERM *)NULL ) + error(E_NULL,"px_transp"); + + if ( i1 < px->size && i2 < px->size ) + { + temp = px->pe[i1]; + px->pe[i1] = px->pe[i2]; + px->pe[i2] = temp; + } + + return px; +} + +/* myqsort -- a cheap implementation of Quicksort on integers + -- returns number of swaps */ +static int myqsort(a,num) +int *a, num; +{ + int i, j, tmp, v; + int numswaps; + + numswaps = 0; + if ( num <= 1 ) + return 0; + + i = 0; j = num; v = a[0]; + for ( ; ; ) + { + while ( a[++i] < v ) + ; + while ( a[--j] > v ) + ; + if ( i >= j ) break; + + tmp = a[i]; + a[i] = a[j]; + a[j] = tmp; + numswaps++; + } + + tmp = a[0]; + a[0] = a[j]; + a[j] = tmp; + if ( j != 0 ) + numswaps++; + + numswaps += myqsort(&a[0],j); + numswaps += myqsort(&a[j+1],num-(j+1)); + + return numswaps; +} + + +/* px_sign -- compute the ``sign'' of a permutation = +/-1 where + px is the product of an even/odd # transpositions */ +int px_sign(px) +PERM *px; +{ + int numtransp; + PERM *px2; + + if ( px==(PERM *)NULL ) + error(E_NULL,"px_sign"); + px2 = px_copy(px,PNULL); + numtransp = myqsort(px2->pe,px2->size); + px_free(px2); + + return ( numtransp % 2 ) ? -1 : 1; +} + + +/* px_cols -- permute columns of matrix A; out = A.px' + -- May NOT be in situ */ +MAT *px_cols(px,A,out) +PERM *px; +MAT *A, *out; +{ + int i, j, m, n, px_j; + Real **A_me, **out_me; +#ifdef ANSI_C + MAT *m_get(int, int); +#else + extern MAT *m_get(); +#endif + + if ( ! A || ! px ) + error(E_NULL,"px_cols"); + if ( px->size != A->n ) + error(E_SIZES,"px_cols"); + if ( A == out ) + error(E_INSITU,"px_cols"); + m = A->m; n = A->n; + if ( ! out || out->m != m || out->n != n ) + out = m_get(m,n); + A_me = A->me; out_me = out->me; + + for ( j = 0; j < n; j++ ) + { + px_j = px->pe[j]; + if ( px_j >= n ) + error(E_BOUNDS,"px_cols"); + for ( i = 0; i < m; i++ ) + out_me[i][px_j] = A_me[i][j]; + } + + return out; +} + +/* px_rows -- permute columns of matrix A; out = px.A + -- May NOT be in situ */ +MAT *px_rows(px,A,out) +PERM *px; +MAT *A, *out; +{ + int i, j, m, n, px_i; + Real **A_me, **out_me; +#ifdef ANSI_C + MAT *m_get(int, int); +#else + extern MAT *m_get(); +#endif + + if ( ! A || ! px ) + error(E_NULL,"px_rows"); + if ( px->size != A->m ) + error(E_SIZES,"px_rows"); + if ( A == out ) + error(E_INSITU,"px_rows"); + m = A->m; n = A->n; + if ( ! out || out->m != m || out->n != n ) + out = m_get(m,n); + A_me = A->me; out_me = out->me; + + for ( i = 0; i < m; i++ ) + { + px_i = px->pe[i]; + if ( px_i >= m ) + error(E_BOUNDS,"px_rows"); + for ( j = 0; j < n; j++ ) + out_me[i][j] = A_me[px_i][j]; + } + + return out; +} + diff --git a/meschach/qrfactor.c b/meschach/qrfactor.c new file mode 100644 index 0000000..8d48765 --- /dev/null +++ b/meschach/qrfactor.c @@ -0,0 +1,515 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + This file contains the routines needed to perform QR factorisation + of matrices, as well as Householder transformations. + The internal "factored form" of a matrix A is not quite standard. + The diagonal of A is replaced by the diagonal of R -- not by the 1st non-zero + entries of the Householder vectors. The 1st non-zero entries are held in + the diag parameter of QRfactor(). The reason for this non-standard + representation is that it enables direct use of the Usolve() function + rather than requiring that a seperate function be written just for this case. + See, e.g., QRsolve() below for more details. + +*/ + + +static char rcsid[] = "$Id: qrfactor.c,v 1.1 2001/03/01 17:18:57 rfranke Exp $"; + +#include +#include +#include "matrix2.h" + + + + + +#define sign(x) ((x) > 0.0 ? 1 : ((x) < 0.0 ? -1 : 0 )) + +extern VEC *Usolve(); /* See matrix2.h */ + +/* Note: The usual representation of a Householder transformation is taken + to be: + P = I - beta.u.uT + where beta = 2/(uT.u) and u is called the Householder vector + */ + +/* QRfactor -- forms the QR factorisation of A -- factorisation stored in + compact form as described above ( not quite standard format ) */ +/* MAT *QRfactor(A,diag,beta) */ +MAT *QRfactor(A,diag) +MAT *A; +VEC *diag /* ,*beta */; +{ + u_int k,limit; + Real beta; + static VEC *tmp1=VNULL; + + if ( ! A || ! diag ) + error(E_NULL,"QRfactor"); + limit = min(A->m,A->n); + if ( diag->dim < limit ) + error(E_SIZES,"QRfactor"); + + tmp1 = v_resize(tmp1,A->m); + MEM_STAT_REG(tmp1,TYPE_VEC); + + for ( k=0; kve[k],tmp1,&A->me[k][k]); */ + hhvec(tmp1,k,&beta,tmp1,&A->me[k][k]); + diag->ve[k] = tmp1->ve[k]; + + /* apply H/holder vector to remaining columns */ + /* hhtrcols(A,k,k+1,tmp1,beta->ve[k]); */ + hhtrcols(A,k,k+1,tmp1,beta); + } + + return (A); +} + +/* QRCPfactor -- forms the QR factorisation of A with column pivoting + -- factorisation stored in compact form as described above + ( not quite standard format ) */ +/* MAT *QRCPfactor(A,diag,beta,px) */ +MAT *QRCPfactor(A,diag,px) +MAT *A; +VEC *diag /* , *beta */; +PERM *px; +{ + u_int i, i_max, j, k, limit; + static VEC *gamma=VNULL, *tmp1=VNULL, *tmp2=VNULL; + Real beta, maxgamma, sum, tmp; + + if ( ! A || ! diag || ! px ) + error(E_NULL,"QRCPfactor"); + limit = min(A->m,A->n); + if ( diag->dim < limit || px->size != A->n ) + error(E_SIZES,"QRCPfactor"); + + tmp1 = v_resize(tmp1,A->m); + tmp2 = v_resize(tmp2,A->m); + gamma = v_resize(gamma,A->n); + MEM_STAT_REG(tmp1,TYPE_VEC); + MEM_STAT_REG(tmp2,TYPE_VEC); + MEM_STAT_REG(gamma,TYPE_VEC); + + /* initialise gamma and px */ + for ( j=0; jn; j++ ) + { + px->pe[j] = j; + sum = 0.0; + for ( i=0; im; i++ ) + sum += square(A->me[i][j]); + gamma->ve[j] = sum; + } + + for ( k=0; kve[k]; + for ( i=k+1; in; i++ ) + /* Loop invariant:maxgamma=gamma[i_max] + >=gamma[l];l=k,...,i-1 */ + if ( gamma->ve[i] > maxgamma ) + { maxgamma = gamma->ve[i]; i_max = i; } + + /* swap columns if necessary */ + if ( i_max != k ) + { + /* swap gamma values */ + tmp = gamma->ve[k]; + gamma->ve[k] = gamma->ve[i_max]; + gamma->ve[i_max] = tmp; + + /* update column permutation */ + px_transp(px,k,i_max); + + /* swap columns of A */ + for ( i=0; im; i++ ) + { + tmp = A->me[i][k]; + A->me[i][k] = A->me[i][i_max]; + A->me[i][i_max] = tmp; + } + } + + /* get H/holder vector for the k-th column */ + get_col(A,k,tmp1); + /* hhvec(tmp1,k,&beta->ve[k],tmp1,&A->me[k][k]); */ + hhvec(tmp1,k,&beta,tmp1,&A->me[k][k]); + diag->ve[k] = tmp1->ve[k]; + + /* apply H/holder vector to remaining columns */ + /* hhtrcols(A,k,k+1,tmp1,beta->ve[k]); */ + hhtrcols(A,k,k+1,tmp1,beta); + + /* update gamma values */ + for ( j=k+1; jn; j++ ) + gamma->ve[j] -= square(A->me[k][j]); + } + + return (A); +} + +/* Qsolve -- solves Qx = b, Q is an orthogonal matrix stored in compact + form a la QRfactor() -- may be in-situ */ +/* VEC *_Qsolve(QR,diag,beta,b,x,tmp) */ +VEC *_Qsolve(QR,diag,b,x,tmp) +MAT *QR; +VEC *diag /* ,*beta */ , *b, *x, *tmp; +{ + u_int dynamic; + int k, limit; + Real beta, r_ii, tmp_val; + + limit = min(QR->m,QR->n); + dynamic = FALSE; + if ( ! QR || ! diag || ! b ) + error(E_NULL,"_Qsolve"); + if ( diag->dim < limit || b->dim != QR->m ) + error(E_SIZES,"_Qsolve"); + x = v_resize(x,QR->m); + if ( tmp == VNULL ) + dynamic = TRUE; + tmp = v_resize(tmp,QR->m); + + /* apply H/holder transforms in normal order */ + x = v_copy(b,x); + for ( k = 0 ; k < limit ; k++ ) + { + get_col(QR,k,tmp); + r_ii = fabs(tmp->ve[k]); + tmp->ve[k] = diag->ve[k]; + tmp_val = (r_ii*fabs(diag->ve[k])); + beta = ( tmp_val == 0.0 ) ? 0.0 : 1.0/tmp_val; + /* hhtrvec(tmp,beta->ve[k],k,x,x); */ + hhtrvec(tmp,beta,k,x,x); + } + + if ( dynamic ) + V_FREE(tmp); + + return (x); +} + +/* makeQ -- constructs orthogonal matrix from Householder vectors stored in + compact QR form */ +/* MAT *makeQ(QR,diag,beta,Qout) */ +MAT *makeQ(QR,diag,Qout) +MAT *QR,*Qout; +VEC *diag /* , *beta */; +{ + static VEC *tmp1=VNULL,*tmp2=VNULL; + u_int i, limit; + Real beta, r_ii, tmp_val; + int j; + + limit = min(QR->m,QR->n); + if ( ! QR || ! diag ) + error(E_NULL,"makeQ"); + if ( diag->dim < limit ) + error(E_SIZES,"makeQ"); + if ( Qout==(MAT *)NULL || Qout->m < QR->m || Qout->n < QR->m ) + Qout = m_get(QR->m,QR->m); + + tmp1 = v_resize(tmp1,QR->m); /* contains basis vec & columns of Q */ + tmp2 = v_resize(tmp2,QR->m); /* contains H/holder vectors */ + MEM_STAT_REG(tmp1,TYPE_VEC); + MEM_STAT_REG(tmp2,TYPE_VEC); + + for ( i=0; im ; i++ ) + { /* get i-th column of Q */ + /* set up tmp1 as i-th basis vector */ + for ( j=0; jm ; j++ ) + tmp1->ve[j] = 0.0; + tmp1->ve[i] = 1.0; + + /* apply H/h transforms in reverse order */ + for ( j=limit-1; j>=0; j-- ) + { + get_col(QR,j,tmp2); + r_ii = fabs(tmp2->ve[j]); + tmp2->ve[j] = diag->ve[j]; + tmp_val = (r_ii*fabs(diag->ve[j])); + beta = ( tmp_val == 0.0 ) ? 0.0 : 1.0/tmp_val; + /* hhtrvec(tmp2,beta->ve[j],j,tmp1,tmp1); */ + hhtrvec(tmp2,beta,j,tmp1,tmp1); + } + + /* insert into Q */ + set_col(Qout,i,tmp1); + } + + return (Qout); +} + +/* makeR -- constructs upper triangular matrix from QR (compact form) + -- may be in-situ (all it does is zero the lower 1/2) */ +MAT *makeR(QR,Rout) +MAT *QR,*Rout; +{ + u_int i,j; + + if ( QR==(MAT *)NULL ) + error(E_NULL,"makeR"); + Rout = m_copy(QR,Rout); + + for ( i=1; im; i++ ) + for ( j=0; jn && jme[i][j] = 0.0; + + return (Rout); +} + +/* QRsolve -- solves the system Q.R.x=b where Q & R are stored in compact form + -- returns x, which is created if necessary */ +/* VEC *QRsolve(QR,diag,beta,b,x) */ +VEC *QRsolve(QR,diag,b,x) +MAT *QR; +VEC *diag /* , *beta */ , *b, *x; +{ + int limit; + static VEC *tmp = VNULL; + + if ( ! QR || ! diag || ! b ) + error(E_NULL,"QRsolve"); + limit = min(QR->m,QR->n); + if ( diag->dim < limit || b->dim != QR->m ) + error(E_SIZES,"QRsolve"); + tmp = v_resize(tmp,limit); + MEM_STAT_REG(tmp,TYPE_VEC); + + x = v_resize(x,QR->n); + _Qsolve(QR,diag,b,x,tmp); + x = Usolve(QR,x,x,0.0); + v_resize(x,QR->n); + + return x; +} + +/* QRCPsolve -- solves A.x = b where A is factored by QRCPfactor() + -- assumes that A is in the compact factored form */ +/* VEC *QRCPsolve(QR,diag,beta,pivot,b,x) */ +VEC *QRCPsolve(QR,diag,pivot,b,x) +MAT *QR; +VEC *diag /* , *beta */; +PERM *pivot; +VEC *b, *x; +{ + static VEC *tmp=VNULL; + + if ( ! QR || ! diag || ! pivot || ! b ) + error(E_NULL,"QRCPsolve"); + if ( (QR->m > diag->dim &&QR->n > diag->dim) || QR->n != pivot->size ) + error(E_SIZES,"QRCPsolve"); + + tmp = QRsolve(QR,diag /* , beta */ ,b,tmp); + MEM_STAT_REG(tmp,TYPE_VEC); + x = pxinv_vec(pivot,tmp,x); + + return x; +} + +/* Umlt -- compute out = upper_triang(U).x + -- may be in situ */ +static VEC *Umlt(U,x,out) +MAT *U; +VEC *x, *out; +{ + int i, limit; + + if ( U == MNULL || x == VNULL ) + error(E_NULL,"Umlt"); + limit = min(U->m,U->n); + if ( limit != x->dim ) + error(E_SIZES,"Umlt"); + if ( out == VNULL || out->dim < limit ) + out = v_resize(out,limit); + + for ( i = 0; i < limit; i++ ) + out->ve[i] = __ip__(&(x->ve[i]),&(U->me[i][i]),limit - i); + return out; +} + +/* UTmlt -- returns out = upper_triang(U)^T.x */ +static VEC *UTmlt(U,x,out) +MAT *U; +VEC *x, *out; +{ + Real sum; + int i, j, limit; + + if ( U == MNULL || x == VNULL ) + error(E_NULL,"UTmlt"); + limit = min(U->m,U->n); + if ( out == VNULL || out->dim < limit ) + out = v_resize(out,limit); + + for ( i = limit-1; i >= 0; i-- ) + { + sum = 0.0; + for ( j = 0; j <= i; j++ ) + sum += U->me[j][i]*x->ve[j]; + out->ve[i] = sum; + } + return out; +} + +/* QRTsolve -- solve A^T.sc = c where the QR factors of A are stored in + compact form + -- returns sc + -- original due to Mike Osborne modified Wed 09th Dec 1992 */ +VEC *QRTsolve(A,diag,c,sc) +MAT *A; +VEC *diag, *c, *sc; +{ + int i, j, k, n, p; + Real beta, r_ii, s, tmp_val; + + if ( ! A || ! diag || ! c ) + error(E_NULL,"QRTsolve"); + if ( diag->dim < min(A->m,A->n) ) + error(E_SIZES,"QRTsolve"); + sc = v_resize(sc,A->m); + n = sc->dim; + p = c->dim; + if ( n == p ) + k = p-2; + else + k = p-1; + v_zero(sc); + sc->ve[0] = c->ve[0]/A->me[0][0]; + if ( n == 1) + return sc; + if ( p > 1) + { + for ( i = 1; i < p; i++ ) + { + s = 0.0; + for ( j = 0; j < i; j++ ) + s += A->me[j][i]*sc->ve[j]; + if ( A->me[i][i] == 0.0 ) + error(E_SING,"QRTsolve"); + sc->ve[i]=(c->ve[i]-s)/A->me[i][i]; + } + } + for (i = k; i >= 0; i--) + { + s = diag->ve[i]*sc->ve[i]; + for ( j = i+1; j < n; j++ ) + s += A->me[j][i]*sc->ve[j]; + r_ii = fabs(A->me[i][i]); + tmp_val = (r_ii*fabs(diag->ve[i])); + beta = ( tmp_val == 0.0 ) ? 0.0 : 1.0/tmp_val; + tmp_val = beta*s; + sc->ve[i] -= tmp_val*diag->ve[i]; + for ( j = i+1; j < n; j++ ) + sc->ve[j] -= tmp_val*A->me[j][i]; + } + + return sc; +} + +/* QRcondest -- returns an estimate of the 2-norm condition number of the + matrix factorised by QRfactor() or QRCPfactor() + -- note that as Q does not affect the 2-norm condition number, + it is not necessary to pass the diag, beta (or pivot) vectors + -- generates a lower bound on the true condition number + -- if the matrix is exactly singular, HUGE is returned + -- note that QRcondest() is likely to be more reliable for + matrices factored using QRCPfactor() */ +double QRcondest(QR) +MAT *QR; +{ + static VEC *y=VNULL; + Real norm1, norm2, sum, tmp1, tmp2; + int i, j, limit; + + if ( QR == MNULL ) + error(E_NULL,"QRcondest"); + + limit = min(QR->m,QR->n); + for ( i = 0; i < limit; i++ ) + if ( QR->me[i][i] == 0.0 ) + return HUGE; + + y = v_resize(y,limit); + MEM_STAT_REG(y,TYPE_VEC); + /* use the trick for getting a unit vector y with ||R.y||_inf small + from the LU condition estimator */ + for ( i = 0; i < limit; i++ ) + { + sum = 0.0; + for ( j = 0; j < i; j++ ) + sum -= QR->me[j][i]*y->ve[j]; + sum -= (sum < 0.0) ? 1.0 : -1.0; + y->ve[i] = sum / QR->me[i][i]; + } + UTmlt(QR,y,y); + + /* now apply inverse power method to R^T.R */ + for ( i = 0; i < 3; i++ ) + { + tmp1 = v_norm2(y); + sv_mlt(1/tmp1,y,y); + UTsolve(QR,y,y,0.0); + tmp2 = v_norm2(y); + sv_mlt(1/v_norm2(y),y,y); + Usolve(QR,y,y,0.0); + } + /* now compute approximation for ||R^{-1}||_2 */ + norm1 = sqrt(tmp1)*sqrt(tmp2); + + /* now use complementary approach to compute approximation to ||R||_2 */ + for ( i = limit-1; i >= 0; i-- ) + { + sum = 0.0; + for ( j = i+1; j < limit; j++ ) + sum += QR->me[i][j]*y->ve[j]; + y->ve[i] = (sum >= 0.0) ? 1.0 : -1.0; + y->ve[i] = (QR->me[i][i] >= 0.0) ? y->ve[i] : - y->ve[i]; + } + + /* now apply power method to R^T.R */ + for ( i = 0; i < 3; i++ ) + { + tmp1 = v_norm2(y); + sv_mlt(1/tmp1,y,y); + Umlt(QR,y,y); + tmp2 = v_norm2(y); + sv_mlt(1/tmp2,y,y); + UTmlt(QR,y,y); + } + norm2 = sqrt(tmp1)*sqrt(tmp2); + + /* printf("QRcondest: norm1 = %g, norm2 = %g\n",norm1,norm2); */ + + return norm1*norm2; +} diff --git a/meschach/schur.c b/meschach/schur.c new file mode 100644 index 0000000..a8541d3 --- /dev/null +++ b/meschach/schur.c @@ -0,0 +1,668 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Stewart & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + File containing routines for computing the Schur decomposition + of a real non-symmetric matrix + See also: hessen.c +*/ + +#include +#include +#include "matrix.h" +#include "matrix2.h" + + +static char rcsid[] = "$Id: schur.c,v 1.1 2001/03/01 17:18:58 rfranke Exp $"; + + + +#ifndef ANSI_C +static void hhldr3(x,y,z,nu1,beta,newval) +double x, y, z; +Real *nu1, *beta, *newval; +#else +static void hhldr3(double x, double y, double z, + Real *nu1, Real *beta, Real *newval) +#endif +{ + Real alpha; + + if ( x >= 0.0 ) + alpha = sqrt(x*x+y*y+z*z); + else + alpha = -sqrt(x*x+y*y+z*z); + *nu1 = x + alpha; + *beta = 1.0/(alpha*(*nu1)); + *newval = alpha; +} + +#ifndef ANSI_C +static void hhldr3cols(A,k,j0,beta,nu1,nu2,nu3) +MAT *A; +int k, j0; +double beta, nu1, nu2, nu3; +#else +static void hhldr3cols(MAT *A, int k, int j0, double beta, + double nu1, double nu2, double nu3) +#endif +{ + Real **A_me, ip, prod; + int j, n; + + if ( k < 0 || k+3 > A->m || j0 < 0 ) + error(E_BOUNDS,"hhldr3cols"); + A_me = A->me; n = A->n; + + /* printf("hhldr3cols:(l.%d) j0 = %d, k = %d, A at 0x%lx, m = %d, n = %d\n", + __LINE__, j0, k, (long)A, A->m, A->n); */ + /* printf("hhldr3cols: A (dumped) =\n"); m_dump(stdout,A); */ + + for ( j = j0; j < n; j++ ) + { + /***** + ip = nu1*A_me[k][j] + nu2*A_me[k+1][j] + nu3*A_me[k+2][j]; + prod = ip*beta; + A_me[k][j] -= prod*nu1; + A_me[k+1][j] -= prod*nu2; + A_me[k+2][j] -= prod*nu3; + *****/ + /* printf("hhldr3cols: j = %d\n", j); */ + + ip = nu1*m_entry(A,k,j)+nu2*m_entry(A,k+1,j)+nu3*m_entry(A,k+2,j); + prod = ip*beta; + /***** + m_set_val(A,k ,j,m_entry(A,k ,j) - prod*nu1); + m_set_val(A,k+1,j,m_entry(A,k+1,j) - prod*nu2); + m_set_val(A,k+2,j,m_entry(A,k+2,j) - prod*nu3); + *****/ + m_add_val(A,k ,j,-prod*nu1); + m_add_val(A,k+1,j,-prod*nu2); + m_add_val(A,k+2,j,-prod*nu3); + + } + /* printf("hhldr3cols:(l.%d) j0 = %d, k = %d, m = %d, n = %d\n", + __LINE__, j0, k, A->m, A->n); */ + /* putc('\n',stdout); */ +} + +#ifndef ANSI_C +static void hhldr3rows(A,k,i0,beta,nu1,nu2,nu3) +MAT *A; +int k, i0; +double beta, nu1, nu2, nu3; +#else +static void hhldr3rows(MAT *A, int k, int i0, double beta, + double nu1, double nu2, double nu3) +#endif +{ + Real **A_me, ip, prod; + int i, m; + + /* printf("hhldr3rows:(l.%d) A at 0x%lx\n", __LINE__, (long)A); */ + /* printf("hhldr3rows: k = %d\n", k); */ + if ( k < 0 || k+3 > A->n ) + error(E_BOUNDS,"hhldr3rows"); + A_me = A->me; m = A->m; + i0 = min(i0,m-1); + + for ( i = 0; i <= i0; i++ ) + { + /**** + ip = nu1*A_me[i][k] + nu2*A_me[i][k+1] + nu3*A_me[i][k+2]; + prod = ip*beta; + A_me[i][k] -= prod*nu1; + A_me[i][k+1] -= prod*nu2; + A_me[i][k+2] -= prod*nu3; + ****/ + + ip = nu1*m_entry(A,i,k)+nu2*m_entry(A,i,k+1)+nu3*m_entry(A,i,k+2); + prod = ip*beta; + m_add_val(A,i,k , - prod*nu1); + m_add_val(A,i,k+1, - prod*nu2); + m_add_val(A,i,k+2, - prod*nu3); + + } +} + +/* schur -- computes the Schur decomposition of the matrix A in situ + -- optionally, gives Q matrix such that Q^T.A.Q is upper triangular + -- returns upper triangular Schur matrix */ +MAT *schur(A,Q) +MAT *A, *Q; +{ + int i, j, iter, k, k_min, k_max, k_tmp, n, split; + Real beta2, c, discrim, dummy, nu1, s, t, tmp, x, y, z; + Real **A_me; + Real sqrt_macheps; + static VEC *diag=VNULL, *beta=VNULL; + + if ( ! A ) + error(E_NULL,"schur"); + if ( A->m != A->n || ( Q && Q->m != Q->n ) ) + error(E_SQUARE,"schur"); + if ( Q != MNULL && Q->m != A->m ) + error(E_SIZES,"schur"); + n = A->n; + diag = v_resize(diag,A->n); + beta = v_resize(beta,A->n); + MEM_STAT_REG(diag,TYPE_VEC); + MEM_STAT_REG(beta,TYPE_VEC); + /* compute Hessenberg form */ + Hfactor(A,diag,beta); + + /* save Q if necessary */ + if ( Q ) + Q = makeHQ(A,diag,beta,Q); + makeH(A,A); + + sqrt_macheps = sqrt(MACHEPS); + + k_min = 0; A_me = A->me; + + while ( k_min < n ) + { + Real a00, a01, a10, a11; + double scale, t, numer, denom; + + /* find k_max to suit: + submatrix k_min..k_max should be irreducible */ + k_max = n-1; + for ( k = k_min; k < k_max; k++ ) + /* if ( A_me[k+1][k] == 0.0 ) */ + if ( m_entry(A,k+1,k) == 0.0 ) + { k_max = k; break; } + + if ( k_max <= k_min ) + { + k_min = k_max + 1; + continue; /* outer loop */ + } + + /* check to see if we have a 2 x 2 block + with complex eigenvalues */ + if ( k_max == k_min + 1 ) + { + /* tmp = A_me[k_min][k_min] - A_me[k_max][k_max]; */ + a00 = m_entry(A,k_min,k_min); + a01 = m_entry(A,k_min,k_max); + a10 = m_entry(A,k_max,k_min); + a11 = m_entry(A,k_max,k_max); + tmp = a00 - a11; + /* discrim = tmp*tmp + + 4*A_me[k_min][k_max]*A_me[k_max][k_min]; */ + discrim = tmp*tmp + + 4*a01*a10; + if ( discrim < 0.0 ) + { /* yes -- e-vals are complex + -- put 2 x 2 block in form [a b; c a]; + then eigenvalues have real part a & imag part sqrt(|bc|) */ + numer = - tmp; + denom = ( a01+a10 >= 0.0 ) ? + (a01+a10) + sqrt((a01+a10)*(a01+a10)+tmp*tmp) : + (a01+a10) - sqrt((a01+a10)*(a01+a10)+tmp*tmp); + if ( denom != 0.0 ) + { /* t = s/c = numer/denom */ + t = numer/denom; + scale = c = 1.0/sqrt(1+t*t); + s = c*t; + } + else + { + c = 1.0; + s = 0.0; + } + rot_cols(A,k_min,k_max,c,s,A); + rot_rows(A,k_min,k_max,c,s,A); + if ( Q != MNULL ) + rot_cols(Q,k_min,k_max,c,s,Q); + k_min = k_max + 1; + continue; + } + else /* discrim >= 0; i.e. block has two real eigenvalues */ + { /* no -- e-vals are not complex; + split 2 x 2 block and continue */ + /* s/c = numer/denom */ + numer = ( tmp >= 0.0 ) ? + - tmp - sqrt(discrim) : - tmp + sqrt(discrim); + denom = 2*a01; + if ( fabs(numer) < fabs(denom) ) + { /* t = s/c = numer/denom */ + t = numer/denom; + scale = c = 1.0/sqrt(1+t*t); + s = c*t; + } + else if ( numer != 0.0 ) + { /* t = c/s = denom/numer */ + t = denom/numer; + scale = 1.0/sqrt(1+t*t); + c = fabs(t)*scale; + s = ( t >= 0.0 ) ? scale : -scale; + } + else /* numer == denom == 0 */ + { + c = 0.0; + s = 1.0; + } + rot_cols(A,k_min,k_max,c,s,A); + rot_rows(A,k_min,k_max,c,s,A); + /* A->me[k_max][k_min] = 0.0; */ + if ( Q != MNULL ) + rot_cols(Q,k_min,k_max,c,s,Q); + k_min = k_max + 1; /* go to next block */ + continue; + } + } + + /* now have r x r block with r >= 2: + apply Francis QR step until block splits */ + split = FALSE; iter = 0; + while ( ! split ) + { + iter++; + + /* set up Wilkinson/Francis complex shift */ + k_tmp = k_max - 1; + + a00 = m_entry(A,k_tmp,k_tmp); + a01 = m_entry(A,k_tmp,k_max); + a10 = m_entry(A,k_max,k_tmp); + a11 = m_entry(A,k_max,k_max); + + /* treat degenerate cases differently + -- if there are still no splits after five iterations + and the bottom 2 x 2 looks degenerate, force it to + split */ + if ( iter >= 5 && + fabs(a00-a11) < sqrt_macheps*(fabs(a00)+fabs(a11)) && + (fabs(a01) < sqrt_macheps*(fabs(a00)+fabs(a11)) || + fabs(a10) < sqrt_macheps*(fabs(a00)+fabs(a11))) ) + { + if ( fabs(a01) < sqrt_macheps*(fabs(a00)+fabs(a11)) ) + m_set_val(A,k_tmp,k_max,0.0); + if ( fabs(a10) < sqrt_macheps*(fabs(a00)+fabs(a11)) ) + { + m_set_val(A,k_max,k_tmp,0.0); + split = TRUE; + continue; + } + } + + s = a00 + a11; + t = a00*a11 - a01*a10; + + /* break loop if a 2 x 2 complex block */ + if ( k_max == k_min + 1 && s*s < 4.0*t ) + { + split = TRUE; + continue; + } + + /* perturb shift if convergence is slow */ + if ( (iter % 10) == 0 ) + { s += iter*0.02; t += iter*0.02; + } + + /* set up Householder transformations */ + k_tmp = k_min + 1; + /******************** + x = A_me[k_min][k_min]*A_me[k_min][k_min] + + A_me[k_min][k_tmp]*A_me[k_tmp][k_min] - + s*A_me[k_min][k_min] + t; + y = A_me[k_tmp][k_min]* + (A_me[k_min][k_min]+A_me[k_tmp][k_tmp]-s); + if ( k_min + 2 <= k_max ) + z = A_me[k_tmp][k_min]*A_me[k_min+2][k_tmp]; + else + z = 0.0; + ********************/ + + a00 = m_entry(A,k_min,k_min); + a01 = m_entry(A,k_min,k_tmp); + a10 = m_entry(A,k_tmp,k_min); + a11 = m_entry(A,k_tmp,k_tmp); + + /******************** + a00 = A->me[k_min][k_min]; + a01 = A->me[k_min][k_tmp]; + a10 = A->me[k_tmp][k_min]; + a11 = A->me[k_tmp][k_tmp]; + ********************/ + x = a00*a00 + a01*a10 - s*a00 + t; + y = a10*(a00+a11-s); + if ( k_min + 2 <= k_max ) + z = a10* /* m_entry(A,k_min+2,k_tmp) */ A->me[k_min+2][k_tmp]; + else + z = 0.0; + + for ( k = k_min; k <= k_max-1; k++ ) + { + if ( k < k_max - 1 ) + { + hhldr3(x,y,z,&nu1,&beta2,&dummy); + tracecatch(hhldr3cols(A,k,max(k-1,0), beta2,nu1,y,z),"schur"); + tracecatch(hhldr3rows(A,k,min(n-1,k+3),beta2,nu1,y,z),"schur"); + if ( Q != MNULL ) + hhldr3rows(Q,k,n-1,beta2,nu1,y,z); + } + else + { + givens(x,y,&c,&s); + rot_cols(A,k,k+1,c,s,A); + rot_rows(A,k,k+1,c,s,A); + if ( Q ) + rot_cols(Q,k,k+1,c,s,Q); + } + /* if ( k >= 2 ) + m_set_val(A,k,k-2,0.0); */ + /* x = A_me[k+1][k]; */ + x = m_entry(A,k+1,k); + if ( k <= k_max - 2 ) + /* y = A_me[k+2][k];*/ + y = m_entry(A,k+2,k); + else + y = 0.0; + if ( k <= k_max - 3 ) + /* z = A_me[k+3][k]; */ + z = m_entry(A,k+3,k); + else + z = 0.0; + } + /* if ( k_min > 0 ) + m_set_val(A,k_min,k_min-1,0.0); + if ( k_max < n - 1 ) + m_set_val(A,k_max+1,k_max,0.0); */ + for ( k = k_min; k <= k_max-2; k++ ) + { + /* zero appropriate sub-diagonals */ + m_set_val(A,k+2,k,0.0); + if ( k < k_max-2 ) + m_set_val(A,k+3,k,0.0); + } + + /* test to see if matrix should split */ + for ( k = k_min; k < k_max; k++ ) + if ( fabs(A_me[k+1][k]) < MACHEPS* + (fabs(A_me[k][k])+fabs(A_me[k+1][k+1])) ) + { A_me[k+1][k] = 0.0; split = TRUE; } + } + } + + /* polish up A by zeroing strictly lower triangular elements + and small sub-diagonal elements */ + for ( i = 0; i < A->m; i++ ) + for ( j = 0; j < i-1; j++ ) + A_me[i][j] = 0.0; + for ( i = 0; i < A->m - 1; i++ ) + if ( fabs(A_me[i+1][i]) < MACHEPS* + (fabs(A_me[i][i])+fabs(A_me[i+1][i+1])) ) + A_me[i+1][i] = 0.0; + + return A; +} + +/* schur_vals -- compute real & imaginary parts of eigenvalues + -- assumes T contains a block upper triangular matrix + as produced by schur() + -- real parts stored in real_pt, imaginary parts in imag_pt */ +void schur_evals(T,real_pt,imag_pt) +MAT *T; +VEC *real_pt, *imag_pt; +{ + int i, n; + Real discrim, **T_me; + Real diff, sum, tmp; + + if ( ! T || ! real_pt || ! imag_pt ) + error(E_NULL,"schur_evals"); + if ( T->m != T->n ) + error(E_SQUARE,"schur_evals"); + n = T->n; T_me = T->me; + real_pt = v_resize(real_pt,(u_int)n); + imag_pt = v_resize(imag_pt,(u_int)n); + + i = 0; + while ( i < n ) + { + if ( i < n-1 && T_me[i+1][i] != 0.0 ) + { /* should be a complex eigenvalue */ + sum = 0.5*(T_me[i][i]+T_me[i+1][i+1]); + diff = 0.5*(T_me[i][i]-T_me[i+1][i+1]); + discrim = diff*diff + T_me[i][i+1]*T_me[i+1][i]; + if ( discrim < 0.0 ) + { /* yes -- complex e-vals */ + real_pt->ve[i] = real_pt->ve[i+1] = sum; + imag_pt->ve[i] = sqrt(-discrim); + imag_pt->ve[i+1] = - imag_pt->ve[i]; + } + else + { /* no -- actually both real */ + tmp = sqrt(discrim); + real_pt->ve[i] = sum + tmp; + real_pt->ve[i+1] = sum - tmp; + imag_pt->ve[i] = imag_pt->ve[i+1] = 0.0; + } + i += 2; + } + else + { /* real eigenvalue */ + real_pt->ve[i] = T_me[i][i]; + imag_pt->ve[i] = 0.0; + i++; + } + } +} + +/* schur_vecs -- returns eigenvectors computed from the real Schur + decomposition of a matrix + -- T is the block upper triangular Schur matrix + -- Q is the orthognal matrix where A = Q.T.Q^T + -- if Q is null, the eigenvectors of T are returned + -- X_re is the real part of the matrix of eigenvectors, + and X_im is the imaginary part of the matrix. + -- X_re is returned */ +MAT *schur_vecs(T,Q,X_re,X_im) +MAT *T, *Q, *X_re, *X_im; +{ + int i, j, limit; + Real t11_re, t11_im, t12, t21, t22_re, t22_im; + Real l_re, l_im, det_re, det_im, invdet_re, invdet_im, + val1_re, val1_im, val2_re, val2_im, + tmp_val1_re, tmp_val1_im, tmp_val2_re, tmp_val2_im, **T_me; + Real sum, diff, discrim, magdet, norm, scale; + static VEC *tmp1_re=VNULL, *tmp1_im=VNULL, + *tmp2_re=VNULL, *tmp2_im=VNULL; + + if ( ! T || ! X_re ) + error(E_NULL,"schur_vecs"); + if ( T->m != T->n || X_re->m != X_re->n || + ( Q != MNULL && Q->m != Q->n ) || + ( X_im != MNULL && X_im->m != X_im->n ) ) + error(E_SQUARE,"schur_vecs"); + if ( T->m != X_re->m || + ( Q != MNULL && T->m != Q->m ) || + ( X_im != MNULL && T->m != X_im->m ) ) + error(E_SIZES,"schur_vecs"); + + tmp1_re = v_resize(tmp1_re,T->m); + tmp1_im = v_resize(tmp1_im,T->m); + tmp2_re = v_resize(tmp2_re,T->m); + tmp2_im = v_resize(tmp2_im,T->m); + MEM_STAT_REG(tmp1_re,TYPE_VEC); + MEM_STAT_REG(tmp1_im,TYPE_VEC); + MEM_STAT_REG(tmp2_re,TYPE_VEC); + MEM_STAT_REG(tmp2_im,TYPE_VEC); + + T_me = T->me; + i = 0; + while ( i < T->m ) + { + if ( i+1 < T->m && T->me[i+1][i] != 0.0 ) + { /* complex eigenvalue */ + sum = 0.5*(T_me[i][i]+T_me[i+1][i+1]); + diff = 0.5*(T_me[i][i]-T_me[i+1][i+1]); + discrim = diff*diff + T_me[i][i+1]*T_me[i+1][i]; + l_re = l_im = 0.0; + if ( discrim < 0.0 ) + { /* yes -- complex e-vals */ + l_re = sum; + l_im = sqrt(-discrim); + } + else /* not correct Real Schur form */ + error(E_RANGE,"schur_vecs"); + } + else + { + l_re = T_me[i][i]; + l_im = 0.0; + } + + v_zero(tmp1_im); + v_rand(tmp1_re); + sv_mlt(MACHEPS,tmp1_re,tmp1_re); + + /* solve (T-l.I)x = tmp1 */ + limit = ( l_im != 0.0 ) ? i+1 : i; + /* printf("limit = %d\n",limit); */ + for ( j = limit+1; j < T->m; j++ ) + tmp1_re->ve[j] = 0.0; + j = limit; + while ( j >= 0 ) + { + if ( j > 0 && T->me[j][j-1] != 0.0 ) + { /* 2 x 2 diagonal block */ + /* printf("checkpoint A\n"); */ + val1_re = tmp1_re->ve[j-1] - + __ip__(&(tmp1_re->ve[j+1]),&(T->me[j-1][j+1]),limit-j); + /* printf("checkpoint B\n"); */ + val1_im = tmp1_im->ve[j-1] - + __ip__(&(tmp1_im->ve[j+1]),&(T->me[j-1][j+1]),limit-j); + /* printf("checkpoint C\n"); */ + val2_re = tmp1_re->ve[j] - + __ip__(&(tmp1_re->ve[j+1]),&(T->me[j][j+1]),limit-j); + /* printf("checkpoint D\n"); */ + val2_im = tmp1_im->ve[j] - + __ip__(&(tmp1_im->ve[j+1]),&(T->me[j][j+1]),limit-j); + /* printf("checkpoint E\n"); */ + + t11_re = T_me[j-1][j-1] - l_re; + t11_im = - l_im; + t22_re = T_me[j][j] - l_re; + t22_im = - l_im; + t12 = T_me[j-1][j]; + t21 = T_me[j][j-1]; + + scale = fabs(T_me[j-1][j-1]) + fabs(T_me[j][j]) + + fabs(t12) + fabs(t21) + fabs(l_re) + fabs(l_im); + + det_re = t11_re*t22_re - t11_im*t22_im - t12*t21; + det_im = t11_re*t22_im + t11_im*t22_re; + magdet = det_re*det_re+det_im*det_im; + if ( sqrt(magdet) < MACHEPS*scale ) + { + det_re = MACHEPS*scale; + magdet = det_re*det_re+det_im*det_im; + } + invdet_re = det_re/magdet; + invdet_im = - det_im/magdet; + tmp_val1_re = t22_re*val1_re-t22_im*val1_im-t12*val2_re; + tmp_val1_im = t22_im*val1_re+t22_re*val1_im-t12*val2_im; + tmp_val2_re = t11_re*val2_re-t11_im*val2_im-t21*val1_re; + tmp_val2_im = t11_im*val2_re+t11_re*val2_im-t21*val1_im; + tmp1_re->ve[j-1] = invdet_re*tmp_val1_re - + invdet_im*tmp_val1_im; + tmp1_im->ve[j-1] = invdet_im*tmp_val1_re + + invdet_re*tmp_val1_im; + tmp1_re->ve[j] = invdet_re*tmp_val2_re - + invdet_im*tmp_val2_im; + tmp1_im->ve[j] = invdet_im*tmp_val2_re + + invdet_re*tmp_val2_im; + j -= 2; + } + else + { + t11_re = T_me[j][j] - l_re; + t11_im = - l_im; + magdet = t11_re*t11_re + t11_im*t11_im; + scale = fabs(T_me[j][j]) + fabs(l_re); + if ( sqrt(magdet) < MACHEPS*scale ) + { + t11_re = MACHEPS*scale; + magdet = t11_re*t11_re + t11_im*t11_im; + } + invdet_re = t11_re/magdet; + invdet_im = - t11_im/magdet; + /* printf("checkpoint F\n"); */ + val1_re = tmp1_re->ve[j] - + __ip__(&(tmp1_re->ve[j+1]),&(T->me[j][j+1]),limit-j); + /* printf("checkpoint G\n"); */ + val1_im = tmp1_im->ve[j] - + __ip__(&(tmp1_im->ve[j+1]),&(T->me[j][j+1]),limit-j); + /* printf("checkpoint H\n"); */ + tmp1_re->ve[j] = invdet_re*val1_re - invdet_im*val1_im; + tmp1_im->ve[j] = invdet_im*val1_re + invdet_re*val1_im; + j -= 1; + } + } + + norm = v_norm_inf(tmp1_re) + v_norm_inf(tmp1_im); + sv_mlt(1/norm,tmp1_re,tmp1_re); + if ( l_im != 0.0 ) + sv_mlt(1/norm,tmp1_im,tmp1_im); + mv_mlt(Q,tmp1_re,tmp2_re); + if ( l_im != 0.0 ) + mv_mlt(Q,tmp1_im,tmp2_im); + if ( l_im != 0.0 ) + norm = sqrt(in_prod(tmp2_re,tmp2_re)+in_prod(tmp2_im,tmp2_im)); + else + norm = v_norm2(tmp2_re); + sv_mlt(1/norm,tmp2_re,tmp2_re); + if ( l_im != 0.0 ) + sv_mlt(1/norm,tmp2_im,tmp2_im); + + if ( l_im != 0.0 ) + { + if ( ! X_im ) + error(E_NULL,"schur_vecs"); + set_col(X_re,i,tmp2_re); + set_col(X_im,i,tmp2_im); + sv_mlt(-1.0,tmp2_im,tmp2_im); + set_col(X_re,i+1,tmp2_re); + set_col(X_im,i+1,tmp2_im); + i += 2; + } + else + { + set_col(X_re,i,tmp2_re); + if ( X_im != MNULL ) + set_col(X_im,i,tmp1_im); /* zero vector */ + i += 1; + } + } + + return X_re; +} + diff --git a/meschach/solve.c b/meschach/solve.c new file mode 100644 index 0000000..312f18b --- /dev/null +++ b/meschach/solve.c @@ -0,0 +1,277 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Matrix factorisation routines to work with the other matrix files. +*/ + +/* solve.c 1.2 11/25/87 */ +static char rcsid[] = "$Id: solve.c,v 1.1 2001/03/01 17:18:58 rfranke Exp $"; + +#include +#include +#include "matrix2.h" + + + + + +/* Most matrix factorisation routines are in-situ unless otherwise specified */ + +/* Usolve -- back substitution with optional over-riding diagonal + -- can be in-situ but doesn't need to be */ +VEC *Usolve(matrix,b,out,diag) +MAT *matrix; +VEC *b, *out; +double diag; +{ + u_int dim /* , j */; + int i, i_lim; + Real **mat_ent, *mat_row, *b_ent, *out_ent, *out_col, sum; + + if ( matrix==(MAT *)NULL || b==(VEC *)NULL ) + error(E_NULL,"Usolve"); + dim = min(matrix->m,matrix->n); + if ( b->dim < dim ) + error(E_SIZES,"Usolve"); + if ( out==(VEC *)NULL || out->dim < dim ) + out = v_resize(out,matrix->n); + mat_ent = matrix->me; b_ent = b->ve; out_ent = out->ve; + + for ( i=dim-1; i>=0; i-- ) + if ( b_ent[i] != 0.0 ) + break; + else + out_ent[i] = 0.0; + i_lim = i; + + for ( ; i>=0; i-- ) + { + sum = b_ent[i]; + mat_row = &(mat_ent[i][i+1]); + out_col = &(out_ent[i+1]); + sum -= __ip__(mat_row,out_col,i_lim-i); + /****************************************************** + for ( j=i+1; j<=i_lim; j++ ) + sum -= mat_ent[i][j]*out_ent[j]; + sum -= (*mat_row++)*(*out_col++); + ******************************************************/ + if ( diag==0.0 ) + { + if ( mat_ent[i][i]==0.0 ) + error(E_SING,"Usolve"); + else + out_ent[i] = sum/mat_ent[i][i]; + } + else + out_ent[i] = sum/diag; + } + + return (out); +} + +/* Lsolve -- forward elimination with (optional) default diagonal value */ +VEC *Lsolve(matrix,b,out,diag) +MAT *matrix; +VEC *b,*out; +double diag; +{ + u_int dim, i, i_lim /* , j */; + Real **mat_ent, *mat_row, *b_ent, *out_ent, *out_col, sum; + + if ( matrix==(MAT *)NULL || b==(VEC *)NULL ) + error(E_NULL,"Lsolve"); + dim = min(matrix->m,matrix->n); + if ( b->dim < dim ) + error(E_SIZES,"Lsolve"); + if ( out==(VEC *)NULL || out->dim < dim ) + out = v_resize(out,matrix->n); + mat_ent = matrix->me; b_ent = b->ve; out_ent = out->ve; + + for ( i=0; im,U->n); + if ( b->dim < dim ) + error(E_SIZES,"UTsolve"); + out = v_resize(out,U->n); + U_me = U->me; b_ve = b->ve; out_ve = out->ve; + + for ( i=0; idim); + MEM_COPY(&(b_ve[i_lim]),&(out_ve[i_lim]),(dim-i_lim)*sizeof(Real)); + } + + if ( diag == 0.0 ) + { + for ( ; im,A->n); + if ( b->dim < dim ) + error(E_SIZES,"Dsolve"); + x = v_resize(x,A->n); + + dim = b->dim; + for ( i=0; ime[i][i] == 0.0 ) + error(E_SING,"Dsolve"); + else + x->ve[i] = b->ve[i]/A->me[i][i]; + + return (x); +} + +/* LTsolve -- back substitution with optional over-riding diagonal + using the LOWER triangular part of matrix + -- can be in-situ but doesn't need to be */ +VEC *LTsolve(L,b,out,diag) +MAT *L; +VEC *b, *out; +double diag; +{ + u_int dim; + int i, i_lim; + Real **L_me, *b_ve, *out_ve, tmp, invdiag; + + if ( ! L || ! b ) + error(E_NULL,"LTsolve"); + dim = min(L->m,L->n); + if ( b->dim < dim ) + error(E_SIZES,"LTsolve"); + out = v_resize(out,L->n); + L_me = L->me; b_ve = b->ve; out_ve = out->ve; + + for ( i=dim-1; i>=0; i-- ) + if ( b_ve[i] != 0.0 ) + break; + i_lim = i; + + if ( b != out ) + { + __zero__(out_ve,out->dim); + MEM_COPY(b_ve,out_ve,(i_lim+1)*sizeof(Real)); + } + + if ( diag == 0.0 ) + { + for ( ; i>=0; i-- ) + { + tmp = L_me[i][i]; + if ( tmp == 0.0 ) + error(E_SING,"LTsolve"); + out_ve[i] /= tmp; + __mltadd__(out_ve,L_me[i],-out_ve[i],i); + } + } + else + { + invdiag = 1.0/diag; + for ( ; i>=0; i-- ) + { + out_ve[i] *= invdiag; + __mltadd__(out_ve,L_me[i],-out_ve[i],i); + } + } + + return (out); +} diff --git a/meschach/sparsdef.h b/meschach/sparsdef.h new file mode 100644 index 0000000..a151aac --- /dev/null +++ b/meschach/sparsdef.h @@ -0,0 +1,55 @@ +/* + Header for sparse matrix stuff. + Basic sparse routines to be held in sparse.c +*/ + +/* RCS id: $Header: /home/ruediger/hqp/hqp/meschach/sparsdef.h,v 1.1 2001/03/01 17:18:58 rfranke Exp $ */ + +#ifndef SPARSEDEFH + +#define SPARSEDEFH 1 + +/************************************************************************* +* #ifndef MATRIXH +* #include "matrix.h" +* #endif +*************************************************************************/ + +typedef struct row_elt { + int col, nxt_row, nxt_idx; + double val; + } row_elt; + +typedef struct sp_row { + int len, maxlen, diag; + row_elt *elt; /* elt[maxlen] */ + } sp_row; + +typedef struct sp_mat { + int m, n, max_m, max_n; + char flag_col, flag_diag; + sp_row *row; /* row[max_m] */ + int *start_row; /* start_row[max_n] */ + int *start_idx; /* start_idx[max_n] */ + } sp_mat; + +/* Note that the first allocated entry in column j is start_row[j]; + This starts the chain down the columns using the nxt_row and nxt_idx + fields of each entry in each row. */ + +typedef struct SPPAIR { int pos; double val; } SPPAIR; + +typedef struct sp_vec { + int dim, max_dim; + SPPAIR *elt; /* elt[max_dim] */ + } sp_vec; + +#define SMNULL ((sp_mat*)NULL) +#define SVNULL ((sp_vec*)NULL) + +/* Macro for speedup */ +#define sp_get_idx2(r,c,hint) \ + ( ( (hint) >= 0 && (hint) < (r)->len && \ + (r)->elt[hint].col == (c)) ? (hint) : sp_get_idx((r),(c)) ) + +#endif diff --git a/meschach/sparse.c b/meschach/sparse.c new file mode 100644 index 0000000..2b5f90c --- /dev/null +++ b/meschach/sparse.c @@ -0,0 +1,1037 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + +/* + Sparse matrix package + See also: sparse.h, matrix.h + */ + +#include +#include +#include +#include "sparse.h" + + +static char rcsid[] = "$Id: sparse.c,v 1.1 2001/03/01 17:19:00 rfranke Exp $"; + +#define MINROWLEN 10 + + + +/* sp_get_val -- returns the (i,j) entry of the sparse matrix A */ +double sp_get_val(A,i,j) +SPMAT *A; +int i, j; +{ + SPROW *r; + int idx; + + if ( A == SMNULL ) + error(E_NULL,"sp_get_val"); + if ( i < 0 || i >= A->m || j < 0 || j >= A->n ) + error(E_SIZES,"sp_get_val"); + + r = A->row+i; + idx = sprow_idx(r,j); + if ( idx < 0 ) + return 0.0; + /* else */ + return r->elt[idx].val; +} + +/* sp_set_val -- sets the (i,j) entry of the sparse matrix A */ +double sp_set_val(A,i,j,val) +SPMAT *A; +int i, j; +double val; +{ + SPROW *r; + int idx, idx2, new_len; + + if ( A == SMNULL ) + error(E_NULL,"sp_set_val"); + if ( i < 0 || i >= A->m || j < 0 || j >= A->n ) + error(E_SIZES,"sp_set_val"); + + r = A->row+i; + idx = sprow_idx(r,j); + /* printf("sp_set_val: idx = %d\n",idx); */ + if ( idx >= 0 ) + { r->elt[idx].val = val; return val; } + /* else */ if ( idx < -1 ) + { + /* Note: this destroys the column & diag access paths */ + A->flag_col = A->flag_diag = FALSE; + /* shift & insert new value */ + idx = -(idx+2); /* this is the intended insertion index */ + if ( r->len >= r->maxlen ) + { + r->len = r->maxlen; + new_len = max(2*r->maxlen+1,5); + if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,A->row[i].maxlen*sizeof(row_elt), + new_len*sizeof(row_elt)); + } + + r->elt = RENEW(r->elt,new_len,row_elt); + if ( ! r->elt ) /* can't allocate */ + error(E_MEM,"sp_set_val"); + r->maxlen = new_len; + } + for ( idx2 = r->len-1; idx2 >= idx; idx2-- ) + MEM_COPY((char *)(&(r->elt[idx2])), + (char *)(&(r->elt[idx2+1])),sizeof(row_elt)); + /************************************************************ + if ( idx < r->len ) + MEM_COPY((char *)(&(r->elt[idx])),(char *)(&(r->elt[idx+1])), + (r->len-idx)*sizeof(row_elt)); + ************************************************************/ + r->len++; + r->elt[idx].col = j; + return r->elt[idx].val = val; + } + /* else -- idx == -1, error in index/matrix! */ + return 0.0; +} + +/* sp_mv_mlt -- sparse matrix/dense vector multiply + -- result is in out, which is returned unless out==NULL on entry + -- if out==NULL on entry then the result vector is created */ +VEC *sp_mv_mlt(A,x,out) +SPMAT *A; +VEC *x, *out; +{ + int i, j_idx, m, n, max_idx; + Real sum, *x_ve; + SPROW *r; + row_elt *elts; + + if ( ! A || ! x ) + error(E_NULL,"sp_mv_mlt"); + if ( x->dim != A->n ) + error(E_SIZES,"sp_mv_mlt"); + if ( ! out || out->dim < A->m ) + out = v_resize(out,A->m); + if ( out == x ) + error(E_INSITU,"sp_mv_mlt"); + m = A->m; n = A->n; + x_ve = x->ve; + + for ( i = 0; i < m; i++ ) + { + sum = 0.0; + r = &(A->row[i]); + max_idx = r->len; + elts = r->elt; + for ( j_idx = 0; j_idx < max_idx; j_idx++, elts++ ) + sum += elts->val*x_ve[elts->col]; + out->ve[i] = sum; + } + return out; +} + +/* sp_vm_mlt -- sparse matrix/dense vector multiply from left + -- result is in out, which is returned unless out==NULL on entry + -- if out==NULL on entry then result vector is created & returned */ +VEC *sp_vm_mlt(A,x,out) +SPMAT *A; +VEC *x, *out; +{ + int i, j_idx, m, n, max_idx; + Real tmp, *x_ve, *out_ve; + SPROW *r; + row_elt *elts; + + if ( ! A || ! x ) + error(E_NULL,"sp_vm_mlt"); + if ( x->dim != A->m ) + error(E_SIZES,"sp_vm_mlt"); + if ( ! out || out->dim < A->n ) + out = v_resize(out,A->n); + if ( out == x ) + error(E_INSITU,"sp_vm_mlt"); + + m = A->m; n = A->n; + v_zero(out); + x_ve = x->ve; out_ve = out->ve; + + for ( i = 0; i < m; i++ ) + { + r = A->row+i; + max_idx = r->len; + elts = r->elt; + tmp = x_ve[i]; + for ( j_idx = 0; j_idx < max_idx; j_idx++, elts++ ) + out_ve[elts->col] += elts->val*tmp; + } + + return out; +} + + +/* sp_get -- get sparse matrix + -- len is number of elements available for each row without + allocating further memory */ +SPMAT *sp_get(m,n,maxlen) +int m, n, maxlen; +{ + SPMAT *A; + SPROW *rows; + int i; + + if ( m < 0 || n < 0 ) + error(E_NEG,"sp_get"); + + maxlen = max(maxlen,1); + + A = NEW(SPMAT); + if ( ! A ) /* can't allocate */ + error(E_MEM,"sp_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,sizeof(SPMAT)); + mem_numvar(TYPE_SPMAT,1); + } + /* fprintf(stderr,"Have SPMAT structure\n"); */ + + A->row = rows = NEW_A(m,SPROW); + if ( ! A->row ) /* can't allocate */ + error(E_MEM,"sp_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,m*sizeof(SPROW)); + } + /* fprintf(stderr,"Have row structure array\n"); */ + + A->start_row = NEW_A(n,int); + A->start_idx = NEW_A(n,int); + if ( ! A->start_row || ! A->start_idx ) /* can't allocate */ + error(E_MEM,"sp_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,2*n*sizeof(int)); + } + for ( i = 0; i < n; i++ ) + A->start_row[i] = A->start_idx[i] = -1; + /* fprintf(stderr,"Have start_row array\n"); */ + + A->m = A->max_m = m; + A->n = A->max_n = n; + + for ( i = 0; i < m; i++, rows++ ) + { + rows->elt = NEW_A(maxlen,row_elt); + if ( ! rows->elt ) + error(E_MEM,"sp_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,maxlen*sizeof(row_elt)); + } + /* fprintf(stderr,"Have row %d element array\n",i); */ + rows->len = 0; + rows->maxlen = maxlen; + rows->diag = -1; + } + + return A; +} + + +/* sp_free -- frees up the memory for a sparse matrix */ +int sp_free(A) +SPMAT *A; +{ + SPROW *r; + int i; + + if ( ! A ) + return -1; + if ( A->start_row != (int *)NULL ) { + if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,A->max_n*sizeof(int),0); + } + free((char *)(A->start_row)); + } + if ( A->start_idx != (int *)NULL ) { + if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,A->max_n*sizeof(int),0); + } + + free((char *)(A->start_idx)); + } + if ( ! A->row ) + { + if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,sizeof(SPMAT),0); + mem_numvar(TYPE_SPMAT,-1); + } + + free((char *)A); + return 0; + } + for ( i = 0; i < A->m; i++ ) + { + r = &(A->row[i]); + if ( r->elt != (row_elt *)NULL ) { + if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,A->row[i].maxlen*sizeof(row_elt),0); + } + free((char *)(r->elt)); + } + } + + if (mem_info_is_on()) { + if (A->row) + mem_bytes(TYPE_SPMAT,A->max_m*sizeof(SPROW),0); + mem_bytes(TYPE_SPMAT,sizeof(SPMAT),0); + mem_numvar(TYPE_SPMAT,-1); + } + + free((char *)(A->row)); + free((char *)A); + + return 0; +} + + +/* sp_copy -- constructs a copy of a given matrix + -- note that the max_len fields (etc) are no larger in the copy + than necessary + -- result is returned */ +SPMAT *sp_copy(A) +SPMAT *A; +{ + SPMAT *out; + SPROW *row1, *row2; + int i; + + if ( A == SMNULL ) + error(E_NULL,"sp_copy"); + if ( ! (out=NEW(SPMAT)) ) + error(E_MEM,"sp_copy"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,sizeof(SPMAT)); + mem_numvar(TYPE_SPMAT,1); + } + out->m = out->max_m = A->m; out->n = out->max_n = A->n; + + /* set up rows */ + if ( ! (out->row=NEW_A(A->m,SPROW)) ) + error(E_MEM,"sp_copy"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,A->m*sizeof(SPROW)); + } + for ( i = 0; i < A->m; i++ ) + { + row1 = &(A->row[i]); + row2 = &(out->row[i]); + if ( ! (row2->elt=NEW_A(max(row1->len,3),row_elt)) ) + error(E_MEM,"sp_copy"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,max(row1->len,3)*sizeof(row_elt)); + } + row2->len = row1->len; + row2->maxlen = max(row1->len,3); + row2->diag = row1->diag; + MEM_COPY((char *)(row1->elt),(char *)(row2->elt), + row1->len*sizeof(row_elt)); + } + + /* set up start arrays -- for column access */ + if ( ! (out->start_idx=NEW_A(A->n,int)) || + ! (out->start_row=NEW_A(A->n,int)) ) + error(E_MEM,"sp_copy"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,2*A->n*sizeof(int)); + } + MEM_COPY((char *)(A->start_idx),(char *)(out->start_idx), + A->n*sizeof(int)); + MEM_COPY((char *)(A->start_row),(char *)(out->start_row), + A->n*sizeof(int)); + + return out; +} + +#ifdef SPARSE_COL_ACCESS +/* sp_col_access -- set column access path; i.e. nxt_row, nxt_idx fields + -- returns A */ +SPMAT *sp_col_access(A) +SPMAT *A; +{ + int i, j, j_idx, len, m, n; + SPROW *row; + row_elt *r_elt; + int *start_row, *start_idx; + + if ( A == SMNULL ) + error(E_NULL,"sp_col_access"); + + m = A->m; n = A->n; + + /* initialise start_row and start_idx */ + start_row = A->start_row; start_idx = A->start_idx; + for ( j = 0; j < n; j++ ) + { *start_row++ = -1; *start_idx++ = -1; } + + start_row = A->start_row; start_idx = A->start_idx; + + /* now work UP the rows, setting nxt_row, nxt_idx fields */ + for ( i = m-1; i >= 0; i-- ) + { + row = &(A->row[i]); + r_elt = row->elt; + len = row->len; + for ( j_idx = 0; j_idx < len; j_idx++, r_elt++ ) + { + j = r_elt->col; + r_elt->nxt_row = start_row[j]; + r_elt->nxt_idx = start_idx[j]; + start_row[j] = i; + start_idx[j] = j_idx; + } + } + + A->flag_col = TRUE; + return A; +} +#endif /* SPARSE_COL_ACCESS */ + +/* sp_diag_access -- set diagonal access path(s) */ +SPMAT *sp_diag_access(A) +SPMAT *A; +{ + int i, m; + SPROW *row; + + if ( A == SMNULL ) + error(E_NULL,"sp_diag_access"); + + m = A->m; + + row = A->row; + for ( i = 0; i < m; i++, row++ ) + row->diag = sprow_idx(row,i); + + A->flag_diag = TRUE; + + return A; +} + +/* sp_m2dense -- convert a sparse matrix to a dense one */ +MAT *sp_m2dense(A,out) +SPMAT *A; +MAT *out; +{ + int i, j_idx; + SPROW *row; + row_elt *elt; + + if ( ! A ) + error(E_NULL,"sp_m2dense"); + if ( ! out || out->m < A->m || out->n < A->n ) + out = m_get(A->m,A->n); + + m_zero(out); + for ( i = 0; i < A->m; i++ ) + { + row = &(A->row[i]); + elt = row->elt; + for ( j_idx = 0; j_idx < row->len; j_idx++, elt++ ) + out->me[i][elt->col] = elt->val; + } + + return out; +} + + +/* C = A+B, can be in situ */ +SPMAT *sp_add(A,B,C) +SPMAT *A, *B, *C; +{ + int i, in_situ; + SPROW *rc; + static SPROW *tmp; + + if ( ! A || ! B ) + error(E_NULL,"sp_add"); + if ( A->m != B->m || A->n != B->n ) + error(E_SIZES,"sp_add"); + if (C == A || C == B) + in_situ = TRUE; + else in_situ = FALSE; + + if ( ! C ) + C = sp_get(A->m,A->n,5); + else { + if ( C->m != A->m || C->n != A->n ) + error(E_SIZES,"sp_add"); + if (!in_situ) sp_zero(C); + } + + if (tmp == (SPROW *)NULL && in_situ) { + tmp = sprow_get(MINROWLEN); + MEM_STAT_REG(tmp,TYPE_SPROW); + } + + if (in_situ) + for (i=0; i < A->m; i++) { + rc = &(C->row[i]); + sprow_add(&(A->row[i]),&(B->row[i]),0,tmp,TYPE_SPROW); + sprow_resize(rc,tmp->len,TYPE_SPMAT); + MEM_COPY(tmp->elt,rc->elt,tmp->len*sizeof(row_elt)); + rc->len = tmp->len; + } + else + for (i=0; i < A->m; i++) { + sprow_add(&(A->row[i]),&(B->row[i]),0,&(C->row[i]),TYPE_SPMAT); + } + + C->flag_col = C->flag_diag = FALSE; + + return C; +} + +/* C = A-B, cannot be in situ */ +SPMAT *sp_sub(A,B,C) +SPMAT *A, *B, *C; +{ + int i, in_situ; + SPROW *rc; + static SPROW *tmp; + + if ( ! A || ! B ) + error(E_NULL,"sp_sub"); + if ( A->m != B->m || A->n != B->n ) + error(E_SIZES,"sp_sub"); + if (C == A || C == B) + in_situ = TRUE; + else in_situ = FALSE; + + if ( ! C ) + C = sp_get(A->m,A->n,5); + else { + if ( C->m != A->m || C->n != A->n ) + error(E_SIZES,"sp_sub"); + if (!in_situ) sp_zero(C); + } + + if (tmp == (SPROW *)NULL && in_situ) { + tmp = sprow_get(MINROWLEN); + MEM_STAT_REG(tmp,TYPE_SPROW); + } + + if (in_situ) + for (i=0; i < A->m; i++) { + rc = &(C->row[i]); + sprow_sub(&(A->row[i]),&(B->row[i]),0,tmp,TYPE_SPROW); + sprow_resize(rc,tmp->len,TYPE_SPMAT); + MEM_COPY(tmp->elt,rc->elt,tmp->len*sizeof(row_elt)); + rc->len = tmp->len; + } + else + for (i=0; i < A->m; i++) { + sprow_sub(&(A->row[i]),&(B->row[i]),0,&(C->row[i]),TYPE_SPMAT); + } + + C->flag_col = C->flag_diag = FALSE; + + return C; +} + +/* C = A+alpha*B, cannot be in situ */ +SPMAT *sp_mltadd(A,B,alpha,C) +SPMAT *A, *B, *C; +double alpha; +{ + int i, in_situ; + SPROW *rc; + static SPROW *tmp; + + if ( ! A || ! B ) + error(E_NULL,"sp_mltadd"); + if ( A->m != B->m || A->n != B->n ) + error(E_SIZES,"sp_mltadd"); + if (C == A || C == B) + in_situ = TRUE; + else in_situ = FALSE; + + if ( ! C ) + C = sp_get(A->m,A->n,5); + else { + if ( C->m != A->m || C->n != A->n ) + error(E_SIZES,"sp_mltadd"); + if (!in_situ) sp_zero(C); + } + + if (tmp == (SPROW *)NULL && in_situ) { + tmp = sprow_get(MINROWLEN); + MEM_STAT_REG(tmp,TYPE_SPROW); + } + + if (in_situ) + for (i=0; i < A->m; i++) { + rc = &(C->row[i]); + sprow_mltadd(&(A->row[i]),&(B->row[i]),alpha,0,tmp,TYPE_SPROW); + sprow_resize(rc,tmp->len,TYPE_SPMAT); + MEM_COPY(tmp->elt,rc->elt,tmp->len*sizeof(row_elt)); + rc->len = tmp->len; + } + else + for (i=0; i < A->m; i++) { + sprow_mltadd(&(A->row[i]),&(B->row[i]),alpha,0, + &(C->row[i]),TYPE_SPMAT); + } + + C->flag_col = C->flag_diag = FALSE; + + return C; +} + + + +/* B = alpha*A, can be in situ */ +SPMAT *sp_smlt(A,alpha,B) +SPMAT *A, *B; +double alpha; +{ + int i; + + if ( ! A ) + error(E_NULL,"sp_smlt"); + if ( ! B ) + B = sp_get(A->m,A->n,5); + else + if ( A->m != B->m || A->n != B->n ) + error(E_SIZES,"sp_smlt"); + + for (i=0; i < A->m; i++) { + sprow_smlt(&(A->row[i]),alpha,0,&(B->row[i]),TYPE_SPMAT); + } + return B; +} + + + +/* sp_zero -- zero all the (represented) elements of a sparse matrix */ +SPMAT *sp_zero(A) +SPMAT *A; +{ + int i, idx, len; + row_elt *elt; + + if ( ! A ) + error(E_NULL,"sp_zero"); + + for ( i = 0; i < A->m; i++ ) + { + elt = A->row[i].elt; + len = A->row[i].len; + for ( idx = 0; idx < len; idx++ ) + (*elt++).val = 0.0; + } + + return A; +} + +/* sp_copy2 -- copy sparse matrix (type 2) + -- keeps structure of the OUT matrix */ +SPMAT *sp_copy2(A,OUT) +SPMAT *A, *OUT; +{ + int i /* , idx, len1, len2 */; + SPROW *r1, *r2; + static SPROW *scratch = (SPROW *)NULL; + /* row_elt *e1, *e2; */ + + if ( ! A ) + error(E_NULL,"sp_copy2"); + if ( ! OUT ) + OUT = sp_get(A->m,A->n,10); + if ( ! scratch ) { + scratch = sprow_xpd(scratch,MINROWLEN,TYPE_SPROW); + MEM_STAT_REG(scratch,TYPE_SPROW); + } + + if ( OUT->m < A->m ) + { + if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,A->max_m*sizeof(SPROW), + A->m*sizeof(SPROW)); + } + + OUT->row = RENEW(OUT->row,A->m,SPROW); + if ( ! OUT->row ) + error(E_MEM,"sp_copy2"); + + for ( i = OUT->m; i < A->m; i++ ) + { + OUT->row[i].elt = NEW_A(MINROWLEN,row_elt); + if ( ! OUT->row[i].elt ) + error(E_MEM,"sp_copy2"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,MINROWLEN*sizeof(row_elt)); + } + + OUT->row[i].maxlen = MINROWLEN; + OUT->row[i].len = 0; + } + OUT->m = A->m; + } + + OUT->flag_col = OUT->flag_diag = FALSE; + /* sp_zero(OUT); */ + + for ( i = 0; i < A->m; i++ ) + { + r1 = &(A->row[i]); r2 = &(OUT->row[i]); + sprow_copy(r1,r2,scratch,TYPE_SPROW); + if ( r2->maxlen < scratch->len ) + sprow_xpd(r2,scratch->len,TYPE_SPMAT); + MEM_COPY((char *)(scratch->elt),(char *)(r2->elt), + scratch->len*sizeof(row_elt)); + r2->len = scratch->len; + /******************************************************* + e1 = r1->elt; e2 = r2->elt; + len1 = r1->len; len2 = r2->len; + for ( idx = 0; idx < len2; idx++, e2++ ) + e2->val = 0.0; + for ( idx = 0; idx < len1; idx++, e1++ ) + sprow_set_val(r2,e1->col,e1->val); + *******************************************************/ + } +#ifdef SP_COL_ACCESS + sp_col_access(OUT); +#endif + return OUT; +} + +/* sp_resize -- resize a sparse matrix + -- don't destroying any contents if possible + -- returns resized matrix */ +SPMAT *sp_resize(A,m,n) +SPMAT *A; +int m, n; +{ + int i, len; + SPROW *r; + + if (m < 0 || n < 0) + error(E_NEG,"sp_resize"); + + if ( ! A ) + return sp_get(m,n,10); + + if (m == A->m && n == A->n) + return A; + + if ( m <= A->max_m ) + { + for ( i = A->m; i < m; i++ ) + A->row[i].len = 0; + A->m = m; + } + else + { + if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,A->max_m*sizeof(SPROW), + m*sizeof(SPROW)); + } + + A->row = RENEW(A->row,(unsigned)m,SPROW); + if ( ! A->row ) + error(E_MEM,"sp_resize"); + for ( i = A->m; i < m; i++ ) + { + if ( ! (A->row[i].elt = NEW_A(MINROWLEN,row_elt)) ) + error(E_MEM,"sp_resize"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,MINROWLEN*sizeof(row_elt)); + } + A->row[i].len = 0; A->row[i].maxlen = MINROWLEN; + } + A->m = A->max_m = m; + } + + /* update number of rows */ + A->n = n; + + /* do we need to increase the size of start_idx[] and start_row[] ? */ + if ( n > A->max_n ) + { /* only have to update the start_idx & start_row arrays */ + if (mem_info_is_on()) + { + mem_bytes(TYPE_SPMAT,2*A->max_n*sizeof(int), + 2*n*sizeof(int)); + } + + A->start_row = RENEW(A->start_row,(unsigned)n,int); + A->start_idx = RENEW(A->start_idx,(unsigned)n,int); + if ( ! A->start_row || ! A->start_idx ) + error(E_MEM,"sp_resize"); + A->max_n = n; /* ...and update max_n */ + + return A; + } + + if ( n <= A->n ) + /* make sure that all rows are truncated just before column n */ + for ( i = 0; i < A->m; i++ ) + { + r = &(A->row[i]); + len = sprow_idx(r,n); + if ( len < 0 ) + len = -(len+2); + if ( len < 0 ) + error(E_MEM,"sp_resize"); + r->len = len; + } + + return A; +} + + +/* sp_compact -- removes zeros and near-zeros from a sparse matrix */ +SPMAT *sp_compact(A,tol) +SPMAT *A; +double tol; +{ + int i, idx1, idx2; + SPROW *r; + row_elt *elt1, *elt2; + + if ( ! A ) + error(E_NULL,"sp_compact"); + if ( tol < 0.0 ) + error(E_RANGE,"sp_compact"); + + A->flag_col = A->flag_diag = FALSE; + + for ( i = 0; i < A->m; i++ ) + { + r = &(A->row[i]); + elt1 = elt2 = r->elt; + idx1 = idx2 = 0; + while ( idx1 < r->len ) + { + /* printf("# sp_compact: idx1 = %d, idx2 = %d\n",idx1,idx2); */ + if ( fabs(elt1->val) <= tol ) + { idx1++; elt1++; continue; } + if ( elt1 != elt2 ) + MEM_COPY(elt1,elt2,sizeof(row_elt)); + idx1++; elt1++; + idx2++; elt2++; + } + r->len = idx2; + } + + return A; +} + +/* varying number of arguments */ + +#ifdef ANSI_C + +/* To allocate memory to many arguments. + The function should be called: + sp_get_vars(m,n,deg,&x,&y,&z,...,NULL); + where + int m,n,deg; + SPMAT *x, *y, *z,...; + The last argument should be NULL ! + m x n is the dimension of matrices x,y,z,... + returned value is equal to the number of allocated variables +*/ + +int sp_get_vars(int m,int n,int deg,...) +{ + va_list ap; + int i=0; + SPMAT **par; + + va_start(ap, deg); + while (par = va_arg(ap,SPMAT **)) { /* NULL ends the list*/ + *par = sp_get(m,n,deg); + i++; + } + + va_end(ap); + return i; +} + + +/* To resize memory for many arguments. + The function should be called: + sp_resize_vars(m,n,&x,&y,&z,...,NULL); + where + int m,n; + SPMAT *x, *y, *z,...; + The last argument should be NULL ! + m X n is the resized dimension of matrices x,y,z,... + returned value is equal to the number of allocated variables. + If one of x,y,z,.. arguments is NULL then memory is allocated to this + argument. +*/ + +int sp_resize_vars(int m,int n,...) +{ + va_list ap; + int i=0; + SPMAT **par; + + va_start(ap, n); + while (par = va_arg(ap,SPMAT **)) { /* NULL ends the list*/ + *par = sp_resize(*par,m,n); + i++; + } + + va_end(ap); + return i; +} + +/* To deallocate memory for many arguments. + The function should be called: + sp_free_vars(&x,&y,&z,...,NULL); + where + SPMAT *x, *y, *z,...; + The last argument should be NULL ! + There must be at least one not NULL argument. + returned value is equal to the number of allocated variables. + Returned value of x,y,z,.. is VNULL. +*/ + +int sp_free_vars(SPMAT **va,...) +{ + va_list ap; + int i=1; + SPMAT **par; + + sp_free(*va); + *va = (SPMAT *) NULL; + va_start(ap, va); + while (par = va_arg(ap,SPMAT **)) { /* NULL ends the list*/ + sp_free(*par); + *par = (SPMAT *)NULL; + i++; + } + + va_end(ap); + return i; +} + + +#elif VARARGS + +/* To allocate memory to many arguments. + The function should be called: + sp_get_vars(m,n,deg,&x,&y,&z,...,NULL); + where + int m,n,deg; + SPMAT *x, *y, *z,...; + The last argument should be NULL ! + m x n is the dimension of matrices x,y,z,... + returned value is equal to the number of allocated variables +*/ + +int sp_get_vars(va_alist) va_dcl +{ + va_list ap; + int i=0, m, n, deg; + SPMAT **par; + + va_start(ap); + m = va_arg(ap,int); + n = va_arg(ap,int); + deg = va_arg(ap,int); + while (par = va_arg(ap,SPMAT **)) { /* NULL ends the list*/ + *par = sp_get(m,n,deg); + i++; + } + + va_end(ap); + return i; +} + + +/* To resize memory for many arguments. + The function should be called: + sp_resize_vars(m,n,&x,&y,&z,...,NULL); + where + int m,n; + SPMAT *x, *y, *z,...; + The last argument should be NULL ! + m X n is the resized dimension of matrices x,y,z,... + returned value is equal to the number of allocated variables. + If one of x,y,z,.. arguments is NULL then memory is allocated to this + argument. +*/ + +int sp_resize_vars(va_alist) va_dcl +{ + va_list ap; + int i=0, m, n; + SPMAT **par; + + va_start(ap); + m = va_arg(ap,int); + n = va_arg(ap,int); + while (par = va_arg(ap,SPMAT **)) { /* NULL ends the list*/ + *par = sp_resize(*par,m,n); + i++; + } + + va_end(ap); + return i; +} + + + +/* To deallocate memory for many arguments. + The function should be called: + sp_free_vars(&x,&y,&z,...,NULL); + where + SPMAT *x, *y, *z,...; + The last argument should be NULL ! + There must be at least one not NULL argument. + returned value is equal to the number of allocated variables. + Returned value of x,y,z,.. is VNULL. +*/ + +int sp_free_vars(va_alist) va_dcl +{ + va_list ap; + int i=0; + SPMAT **par; + + va_start(ap); + while (par = va_arg(ap,SPMAT **)) { /* NULL ends the list*/ + sp_free(*par); + *par = (SPMAT *)NULL; + i++; + } + + va_end(ap); + return i; +} + + + +#endif + diff --git a/meschach/sparse.h b/meschach/sparse.h new file mode 100644 index 0000000..0f9d9b1 --- /dev/null +++ b/meschach/sparse.h @@ -0,0 +1,194 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Header for sparse matrix stuff. + Basic sparse routines to be held in sparse.c +*/ + +/* RCS id: $Id: sparse.h,v 1.1 2001/03/01 17:19:00 rfranke Exp $ */ + +#ifndef SPARSEH + +#define SPARSEH + + +#include "matrix.h" + + +/* basic sparse types */ + +typedef struct row_elt { + Real val; + int col; +#ifdef SPARSE_COL_ACCESS + int nxt_row, nxt_idx; +#endif + } row_elt; + +typedef struct SPROW { + int len, maxlen, diag; + row_elt *elt; /* elt[maxlen] */ + } SPROW; + +typedef struct SPMAT { + int m, n, max_m, max_n; + char flag_col, flag_diag; + SPROW *row; /* row[max_m] */ + int *start_row; /* start_row[max_n] */ + int *start_idx; /* start_idx[max_n] */ + } SPMAT; + +/* Note that the first allocated entry in column j is start_row[j]; + This starts the chain down the columns using the nxt_row and nxt_idx + fields of each entry in each row. */ + +typedef struct SPPAIR { int pos; Real val; } SPPAIR; + +typedef struct SPVEC { + int dim, max_dim; + SPPAIR *elt; /* elt[max_dim] */ + } SPVEC; + +#define SMNULL ((SPMAT*)NULL) +#define SVNULL ((SPVEC*)NULL) + +/* Macro for speedup */ +#define sprow_idx2(r,c,hint) \ + ( ( (hint) >= 0 && (hint) < (r)->len && \ + (r)->elt[hint].col == (c)) ? (hint) : sprow_idx((r),(c)) ) + +MESCH__BEGIN_DECLS + +/* memory functions */ + +int sp_get_vars MESCH__P((int m, int n, int deg, ...)); +int sp_resize_vars MESCH__P((int m, int n, ...)); +int sp_free_vars MESCH__P((SPMAT **, ...)); + +/* Sparse Matrix Operations and Utilities */ + +SPMAT *sp_get MESCH__P((int, int, int)); +SPMAT *sp_copy MESCH__P((const SPMAT *)); +SPMAT *sp_copy2 MESCH__P((const SPMAT *, SPMAT *)); +SPMAT *sp_zero MESCH__P((SPMAT *)); +SPMAT *sp_resize MESCH__P((SPMAT *,int, int)); +SPMAT *sp_compact MESCH__P((SPMAT *, double)); +double sp_get_val MESCH__P((const SPMAT *, int, int)); +double sp_set_val MESCH__P((SPMAT *, int, int, double)); +VEC *sp_mv_mlt MESCH__P((const SPMAT *, const VEC *, VEC *)); +VEC *sp_vm_mlt MESCH__P((const SPMAT *, const VEC *,VEC *)); +int sp_free MESCH__P((SPMAT *)); + +/* Access path operations */ +SPMAT *sp_col_access MESCH__P((SPMAT *)); +SPMAT *sp_diag_access MESCH__P((SPMAT *)); +int chk_col_access MESCH__P((const SPMAT *)); + +/* Input/output operations */ +SPMAT *sp_finput MESCH__P((FILE *)); +void sp_foutput MESCH__P((FILE *, const SPMAT *)); +void sp_foutput2 MESCH__P((FILE * , const SPMAT *)); + +/* algebraic operations */ +SPMAT *sp_smlt MESCH__P((const SPMAT *A, double alpha, SPMAT *B)); +SPMAT *sp_add MESCH__P((const SPMAT *A, const SPMAT *B, SPMAT *C)); +SPMAT *sp_sub MESCH__P((const SPMAT *A, const SPMAT *B, SPMAT *C)); +SPMAT *sp_mltadd MESCH__P((const SPMAT *A, const SPMAT *B, double alpha, + SPMAT *C)); + +/* sparse row operations */ +SPROW *sprow_get MESCH__P((int)), *sprow_xpd MESCH__P((SPROW *r, int n, int type)); +SPROW *sprow_resize MESCH__P((SPROW *r, int n, int type)); +SPROW *sprow_merge MESCH__P((const SPROW *, const SPROW *, SPROW *, int type)); +SPROW *sprow_copy MESCH__P((const SPROW *, const SPROW *, SPROW *, int type)); +SPROW *sprow_mltadd MESCH__P((const SPROW *, const SPROW *, double, int, + SPROW *, int type)); +SPROW *sprow_add MESCH__P((const SPROW *r1, const SPROW *r2, int j0, + SPROW *r_out, int type)); +SPROW *sprow_sub MESCH__P((const SPROW *r1, const SPROW *r2, int j0, + SPROW *r_out, int type)); +SPROW *sprow_smlt MESCH__P((const SPROW *r1, double alpha, int j0, + SPROW *r_out, int type)); +double sprow_set_val MESCH__P((SPROW *, int, double)); +int sprow_free MESCH__P((SPROW *)); +int sprow_idx MESCH__P((const SPROW *, int)); +void sprow_foutput MESCH__P((FILE *, const SPROW *)); + +/* dump */ +void sp_dump MESCH__P((FILE *fp, const SPMAT *A)); +void sprow_dump MESCH__P((FILE *fp, SPROW *r)); +MAT *sp_m2dense MESCH__P((const SPMAT *A, MAT *out)); + + +/* MACROS */ + +#define sp_input() sp_finput(stdin) +#define sp_output(A) sp_foutput(stdout,(A)) +#define sp_output2(A) sp_foutput2(stdout,(A)) +#define row_mltadd(r1,r2,alpha,out) sprow_mltadd(r1,r2,alpha,0,out) +#define out_row(r) sprow_foutput(stdout,(r)) + +#define SP_FREE(A) ( sp_free((A)), (A)=(SPMAT *)NULL) + +/* utility for index computations -- ensures index returned >= 0 */ +#define fixindex(idx) ((idx) == -1 ? (error(E_BOUNDS,"fixindex"),0) : \ + (idx) < 0 ? -((idx)+2) : (idx)) + + +/* NOT USED */ + +/* loop over the columns in a row */ +/* +#define loop_cols(r,e,code) \ + do { int _r_idx; row_elt *e; SPROW *_t_row; \ + _t_row = (r); e = &(_t_row->elt); \ + for ( _r_idx = 0; _r_idx < _t_row->len; _r_idx++, e++ ) \ + { code; } } while ( 0 ) +*/ +/* loop over the rows in a column */ +/* +#define loop_cols(A,col,e,code) \ + do { int _r_num, _r_idx, _c; SPROW *_r; row_elt *e; \ + if ( ! (A)->flag_col ) sp_col_access((A)); \ + col_num = (col); \ + if ( col_num < 0 || col_num >= A->n ) \ + error(E_BOUNDS,"loop_cols"); \ + _r_num = (A)->start_row[_c]; _r_idx = (A)->start_idx[_c]; \ + while ( _r_num >= 0 ) { \ + _r = &((A)->row[_r_num]); \ + _r_idx = sprow_idx2(_r,_c,_r_idx); \ + if ( _r_idx < 0 ) continue; \ + e = &(_r->elt[_r_idx]); code; \ + _r_num = e->nxt_row; _r_idx = e->nxt_idx; \ + } } while ( 0 ) + +*/ + +MESCH__END_DECLS + +#endif + diff --git a/meschach/sparse.org.c b/meschach/sparse.org.c new file mode 100644 index 0000000..7248dc1 --- /dev/null +++ b/meschach/sparse.org.c @@ -0,0 +1,1037 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + +/* + Sparse matrix package + See also: sparse.h, matrix.h + */ + +#include +#include +#include +#include "sparse.h" + + +static char rcsid[] = "$Id: sparse.org.c,v 1.1 2001/03/01 17:19:02 rfranke Exp $"; + +#define MINROWLEN 10 + + + +/* sp_get_val -- returns the (i,j) entry of the sparse matrix A */ +double sp_get_val(A,i,j) +SPMAT *A; +int i, j; +{ + SPROW *r; + int idx; + + if ( A == SMNULL ) + error(E_NULL,"sp_get_val"); + if ( i < 0 || i >= A->m || j < 0 || j >= A->n ) + error(E_SIZES,"sp_get_val"); + + r = A->row+i; + idx = sprow_idx(r,j); + if ( idx < 0 ) + return 0.0; + /* else */ + return r->elt[idx].val; +} + +/* sp_set_val -- sets the (i,j) entry of the sparse matrix A */ +double sp_set_val(A,i,j,val) +SPMAT *A; +int i, j; +double val; +{ + SPROW *r; + int idx, idx2, new_len; + + if ( A == SMNULL ) + error(E_NULL,"sp_set_val"); + if ( i < 0 || i >= A->m || j < 0 || j >= A->n ) + error(E_SIZES,"sp_set_val"); + + r = A->row+i; + idx = sprow_idx(r,j); + /* printf("sp_set_val: idx = %d\n",idx); */ + if ( idx >= 0 ) + { r->elt[idx].val = val; return val; } + /* else */ if ( idx < -1 ) + { + /* Note: this destroys the column & diag access paths */ + A->flag_col = A->flag_diag = FALSE; + /* shift & insert new value */ + idx = -(idx+2); /* this is the intended insertion index */ + if ( r->len >= r->maxlen ) + { + r->len = r->maxlen; + new_len = max(2*r->maxlen+1,5); + if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,A->row[i].maxlen*sizeof(row_elt), + new_len*sizeof(row_elt)); + } + + r->elt = RENEW(r->elt,new_len,row_elt); + if ( ! r->elt ) /* can't allocate */ + error(E_MEM,"sp_set_val"); + r->maxlen = 2*r->maxlen+1; + } + for ( idx2 = r->len-1; idx2 >= idx; idx2-- ) + MEM_COPY((char *)(&(r->elt[idx2])), + (char *)(&(r->elt[idx2+1])),sizeof(row_elt)); + /************************************************************ + if ( idx < r->len ) + MEM_COPY((char *)(&(r->elt[idx])),(char *)(&(r->elt[idx+1])), + (r->len-idx)*sizeof(row_elt)); + ************************************************************/ + r->len++; + r->elt[idx].col = j; + return r->elt[idx].val = val; + } + /* else -- idx == -1, error in index/matrix! */ + return 0.0; +} + +/* sp_mv_mlt -- sparse matrix/dense vector multiply + -- result is in out, which is returned unless out==NULL on entry + -- if out==NULL on entry then the result vector is created */ +VEC *sp_mv_mlt(A,x,out) +SPMAT *A; +VEC *x, *out; +{ + int i, j_idx, m, n, max_idx; + Real sum, *x_ve; + SPROW *r; + row_elt *elts; + + if ( ! A || ! x ) + error(E_NULL,"sp_mv_mlt"); + if ( x->dim != A->n ) + error(E_SIZES,"sp_mv_mlt"); + if ( ! out || out->dim < A->m ) + out = v_resize(out,A->m); + if ( out == x ) + error(E_INSITU,"sp_mv_mlt"); + m = A->m; n = A->n; + x_ve = x->ve; + + for ( i = 0; i < m; i++ ) + { + sum = 0.0; + r = &(A->row[i]); + max_idx = r->len; + elts = r->elt; + for ( j_idx = 0; j_idx < max_idx; j_idx++, elts++ ) + sum += elts->val*x_ve[elts->col]; + out->ve[i] = sum; + } + return out; +} + +/* sp_vm_mlt -- sparse matrix/dense vector multiply from left + -- result is in out, which is returned unless out==NULL on entry + -- if out==NULL on entry then result vector is created & returned */ +VEC *sp_vm_mlt(A,x,out) +SPMAT *A; +VEC *x, *out; +{ + int i, j_idx, m, n, max_idx; + Real tmp, *x_ve, *out_ve; + SPROW *r; + row_elt *elts; + + if ( ! A || ! x ) + error(E_NULL,"sp_vm_mlt"); + if ( x->dim != A->m ) + error(E_SIZES,"sp_vm_mlt"); + if ( ! out || out->dim < A->n ) + out = v_resize(out,A->n); + if ( out == x ) + error(E_INSITU,"sp_vm_mlt"); + + m = A->m; n = A->n; + v_zero(out); + x_ve = x->ve; out_ve = out->ve; + + for ( i = 0; i < m; i++ ) + { + r = A->row+i; + max_idx = r->len; + elts = r->elt; + tmp = x_ve[i]; + for ( j_idx = 0; j_idx < max_idx; j_idx++, elts++ ) + out_ve[elts->col] += elts->val*tmp; + } + + return out; +} + + +/* sp_get -- get sparse matrix + -- len is number of elements available for each row without + allocating further memory */ +SPMAT *sp_get(m,n,maxlen) +int m, n, maxlen; +{ + SPMAT *A; + SPROW *rows; + int i; + + if ( m < 0 || n < 0 ) + error(E_NEG,"sp_get"); + + maxlen = max(maxlen,1); + + A = NEW(SPMAT); + if ( ! A ) /* can't allocate */ + error(E_MEM,"sp_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,sizeof(SPMAT)); + mem_numvar(TYPE_SPMAT,1); + } + /* fprintf(stderr,"Have SPMAT structure\n"); */ + + A->row = rows = NEW_A(m,SPROW); + if ( ! A->row ) /* can't allocate */ + error(E_MEM,"sp_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,m*sizeof(SPROW)); + } + /* fprintf(stderr,"Have row structure array\n"); */ + + A->start_row = NEW_A(n,int); + A->start_idx = NEW_A(n,int); + if ( ! A->start_row || ! A->start_idx ) /* can't allocate */ + error(E_MEM,"sp_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,2*n*sizeof(int)); + } + for ( i = 0; i < n; i++ ) + A->start_row[i] = A->start_idx[i] = -1; + /* fprintf(stderr,"Have start_row array\n"); */ + + A->m = A->max_m = m; + A->n = A->max_n = n; + + for ( i = 0; i < m; i++, rows++ ) + { + rows->elt = NEW_A(maxlen,row_elt); + if ( ! rows->elt ) + error(E_MEM,"sp_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,maxlen*sizeof(row_elt)); + } + /* fprintf(stderr,"Have row %d element array\n",i); */ + rows->len = 0; + rows->maxlen = maxlen; + rows->diag = -1; + } + + return A; +} + + +/* sp_free -- frees up the memory for a sparse matrix */ +int sp_free(A) +SPMAT *A; +{ + SPROW *r; + int i; + + if ( ! A ) + return -1; + if ( A->start_row != (int *)NULL ) { + if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,A->max_n*sizeof(int),0); + } + free((char *)(A->start_row)); + } + if ( A->start_idx != (int *)NULL ) { + if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,A->max_n*sizeof(int),0); + } + + free((char *)(A->start_idx)); + } + if ( ! A->row ) + { + if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,sizeof(SPMAT),0); + mem_numvar(TYPE_SPMAT,-1); + } + + free((char *)A); + return 0; + } + for ( i = 0; i < A->m; i++ ) + { + r = &(A->row[i]); + if ( r->elt != (row_elt *)NULL ) { + if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,A->row[i].maxlen*sizeof(row_elt),0); + } + free((char *)(r->elt)); + } + } + + if (mem_info_is_on()) { + if (A->row) + mem_bytes(TYPE_SPMAT,A->max_m*sizeof(SPROW),0); + mem_bytes(TYPE_SPMAT,sizeof(SPMAT),0); + mem_numvar(TYPE_SPMAT,-1); + } + + free((char *)(A->row)); + free((char *)A); + + return 0; +} + + +/* sp_copy -- constructs a copy of a given matrix + -- note that the max_len fields (etc) are no larger in the copy + than necessary + -- result is returned */ +SPMAT *sp_copy(A) +SPMAT *A; +{ + SPMAT *out; + SPROW *row1, *row2; + int i; + + if ( A == SMNULL ) + error(E_NULL,"sp_copy"); + if ( ! (out=NEW(SPMAT)) ) + error(E_MEM,"sp_copy"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,sizeof(SPMAT)); + mem_numvar(TYPE_SPMAT,1); + } + out->m = out->max_m = A->m; out->n = out->max_n = A->n; + + /* set up rows */ + if ( ! (out->row=NEW_A(A->m,SPROW)) ) + error(E_MEM,"sp_copy"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,A->m*sizeof(SPROW)); + } + for ( i = 0; i < A->m; i++ ) + { + row1 = &(A->row[i]); + row2 = &(out->row[i]); + if ( ! (row2->elt=NEW_A(max(row1->len,3),row_elt)) ) + error(E_MEM,"sp_copy"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,max(row1->len,3)*sizeof(row_elt)); + } + row2->len = row1->len; + row2->maxlen = max(row1->len,3); + row2->diag = row1->diag; + MEM_COPY((char *)(row1->elt),(char *)(row2->elt), + row1->len*sizeof(row_elt)); + } + + /* set up start arrays -- for column access */ + if ( ! (out->start_idx=NEW_A(A->n,int)) || + ! (out->start_row=NEW_A(A->n,int)) ) + error(E_MEM,"sp_copy"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,2*A->n*sizeof(int)); + } + MEM_COPY((char *)(A->start_idx),(char *)(out->start_idx), + A->n*sizeof(int)); + MEM_COPY((char *)(A->start_row),(char *)(out->start_row), + A->n*sizeof(int)); + + return out; +} + +#ifdef SPARSE_COL_ACCESS +/* sp_col_access -- set column access path; i.e. nxt_row, nxt_idx fields + -- returns A */ +SPMAT *sp_col_access(A) +SPMAT *A; +{ + int i, j, j_idx, len, m, n; + SPROW *row; + row_elt *r_elt; + int *start_row, *start_idx; + + if ( A == SMNULL ) + error(E_NULL,"sp_col_access"); + + m = A->m; n = A->n; + + /* initialise start_row and start_idx */ + start_row = A->start_row; start_idx = A->start_idx; + for ( j = 0; j < n; j++ ) + { *start_row++ = -1; *start_idx++ = -1; } + + start_row = A->start_row; start_idx = A->start_idx; + + /* now work UP the rows, setting nxt_row, nxt_idx fields */ + for ( i = m-1; i >= 0; i-- ) + { + row = &(A->row[i]); + r_elt = row->elt; + len = row->len; + for ( j_idx = 0; j_idx < len; j_idx++, r_elt++ ) + { + j = r_elt->col; + r_elt->nxt_row = start_row[j]; + r_elt->nxt_idx = start_idx[j]; + start_row[j] = i; + start_idx[j] = j_idx; + } + } + + A->flag_col = TRUE; + return A; +} +#endif /* SPARSE_COL_ACCESS */ + +/* sp_diag_access -- set diagonal access path(s) */ +SPMAT *sp_diag_access(A) +SPMAT *A; +{ + int i, m; + SPROW *row; + + if ( A == SMNULL ) + error(E_NULL,"sp_diag_access"); + + m = A->m; + + row = A->row; + for ( i = 0; i < m; i++, row++ ) + row->diag = sprow_idx(row,i); + + A->flag_diag = TRUE; + + return A; +} + +/* sp_m2dense -- convert a sparse matrix to a dense one */ +MAT *sp_m2dense(A,out) +SPMAT *A; +MAT *out; +{ + int i, j_idx; + SPROW *row; + row_elt *elt; + + if ( ! A ) + error(E_NULL,"sp_m2dense"); + if ( ! out || out->m < A->m || out->n < A->n ) + out = m_get(A->m,A->n); + + m_zero(out); + for ( i = 0; i < A->m; i++ ) + { + row = &(A->row[i]); + elt = row->elt; + for ( j_idx = 0; j_idx < row->len; j_idx++, elt++ ) + out->me[i][elt->col] = elt->val; + } + + return out; +} + + +/* C = A+B, can be in situ */ +SPMAT *sp_add(A,B,C) +SPMAT *A, *B, *C; +{ + int i, in_situ; + SPROW *rc; + static SPROW *tmp; + + if ( ! A || ! B ) + error(E_NULL,"sp_add"); + if ( A->m != B->m || A->n != B->n ) + error(E_SIZES,"sp_add"); + if (C == A || C == B) + in_situ = TRUE; + else in_situ = FALSE; + + if ( ! C ) + C = sp_get(A->m,A->n,5); + else { + if ( C->m != A->m || C->n != A->n ) + error(E_SIZES,"sp_add"); + if (!in_situ) sp_zero(C); + } + + if (tmp == (SPROW *)NULL && in_situ) { + tmp = sprow_get(MINROWLEN); + MEM_STAT_REG(tmp,TYPE_SPROW); + } + + if (in_situ) + for (i=0; i < A->m; i++) { + rc = &(C->row[i]); + sprow_add(&(A->row[i]),&(B->row[i]),0,tmp,TYPE_SPROW); + sprow_resize(rc,tmp->len,TYPE_SPMAT); + MEM_COPY(tmp->elt,rc->elt,tmp->len*sizeof(row_elt)); + rc->len = tmp->len; + } + else + for (i=0; i < A->m; i++) { + sprow_add(&(A->row[i]),&(B->row[i]),0,&(C->row[i]),TYPE_SPMAT); + } + + C->flag_col = C->flag_diag = FALSE; + + return C; +} + +/* C = A-B, cannot be in situ */ +SPMAT *sp_sub(A,B,C) +SPMAT *A, *B, *C; +{ + int i, in_situ; + SPROW *rc; + static SPROW *tmp; + + if ( ! A || ! B ) + error(E_NULL,"sp_sub"); + if ( A->m != B->m || A->n != B->n ) + error(E_SIZES,"sp_sub"); + if (C == A || C == B) + in_situ = TRUE; + else in_situ = FALSE; + + if ( ! C ) + C = sp_get(A->m,A->n,5); + else { + if ( C->m != A->m || C->n != A->n ) + error(E_SIZES,"sp_sub"); + if (!in_situ) sp_zero(C); + } + + if (tmp == (SPROW *)NULL && in_situ) { + tmp = sprow_get(MINROWLEN); + MEM_STAT_REG(tmp,TYPE_SPROW); + } + + if (in_situ) + for (i=0; i < A->m; i++) { + rc = &(C->row[i]); + sprow_sub(&(A->row[i]),&(B->row[i]),0,tmp,TYPE_SPROW); + sprow_resize(rc,tmp->len,TYPE_SPMAT); + MEM_COPY(tmp->elt,rc->elt,tmp->len*sizeof(row_elt)); + rc->len = tmp->len; + } + else + for (i=0; i < A->m; i++) { + sprow_sub(&(A->row[i]),&(B->row[i]),0,&(C->row[i]),TYPE_SPMAT); + } + + C->flag_col = C->flag_diag = FALSE; + + return C; +} + +/* C = A+alpha*B, cannot be in situ */ +SPMAT *sp_mltadd(A,B,alpha,C) +SPMAT *A, *B, *C; +double alpha; +{ + int i, in_situ; + SPROW *rc; + static SPROW *tmp; + + if ( ! A || ! B ) + error(E_NULL,"sp_mltadd"); + if ( A->m != B->m || A->n != B->n ) + error(E_SIZES,"sp_mltadd"); + if (C == A || C == B) + in_situ = TRUE; + else in_situ = FALSE; + + if ( ! C ) + C = sp_get(A->m,A->n,5); + else { + if ( C->m != A->m || C->n != A->n ) + error(E_SIZES,"sp_mltadd"); + if (!in_situ) sp_zero(C); + } + + if (tmp == (SPROW *)NULL && in_situ) { + tmp = sprow_get(MINROWLEN); + MEM_STAT_REG(tmp,TYPE_SPROW); + } + + if (in_situ) + for (i=0; i < A->m; i++) { + rc = &(C->row[i]); + sprow_mltadd(&(A->row[i]),&(B->row[i]),alpha,0,tmp,TYPE_SPROW); + sprow_resize(rc,tmp->len,TYPE_SPMAT); + MEM_COPY(tmp->elt,rc->elt,tmp->len*sizeof(row_elt)); + rc->len = tmp->len; + } + else + for (i=0; i < A->m; i++) { + sprow_mltadd(&(A->row[i]),&(B->row[i]),alpha,0, + &(C->row[i]),TYPE_SPMAT); + } + + C->flag_col = C->flag_diag = FALSE; + + return C; +} + + + +/* B = alpha*A, can be in situ */ +SPMAT *sp_smlt(A,alpha,B) +SPMAT *A, *B; +double alpha; +{ + int i; + + if ( ! A ) + error(E_NULL,"sp_smlt"); + if ( ! B ) + B = sp_get(A->m,A->n,5); + else + if ( A->m != B->m || A->n != B->n ) + error(E_SIZES,"sp_smlt"); + + for (i=0; i < A->m; i++) { + sprow_smlt(&(A->row[i]),alpha,0,&(B->row[i]),TYPE_SPMAT); + } + return B; +} + + + +/* sp_zero -- zero all the (represented) elements of a sparse matrix */ +SPMAT *sp_zero(A) +SPMAT *A; +{ + int i, idx, len; + row_elt *elt; + + if ( ! A ) + error(E_NULL,"sp_zero"); + + for ( i = 0; i < A->m; i++ ) + { + elt = A->row[i].elt; + len = A->row[i].len; + for ( idx = 0; idx < len; idx++ ) + (*elt++).val = 0.0; + } + + return A; +} + +/* sp_copy2 -- copy sparse matrix (type 2) + -- keeps structure of the OUT matrix */ +SPMAT *sp_copy2(A,OUT) +SPMAT *A, *OUT; +{ + int i /* , idx, len1, len2 */; + SPROW *r1, *r2; + static SPROW *scratch = (SPROW *)NULL; + /* row_elt *e1, *e2; */ + + if ( ! A ) + error(E_NULL,"sp_copy2"); + if ( ! OUT ) + OUT = sp_get(A->m,A->n,10); + if ( ! scratch ) { + scratch = sprow_xpd(scratch,MINROWLEN,TYPE_SPROW); + MEM_STAT_REG(scratch,TYPE_SPROW); + } + + if ( OUT->m < A->m ) + { + if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,A->max_m*sizeof(SPROW), + A->m*sizeof(SPROW)); + } + + OUT->row = RENEW(OUT->row,A->m,SPROW); + if ( ! OUT->row ) + error(E_MEM,"sp_copy2"); + + for ( i = OUT->m; i < A->m; i++ ) + { + OUT->row[i].elt = NEW_A(MINROWLEN,row_elt); + if ( ! OUT->row[i].elt ) + error(E_MEM,"sp_copy2"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,MINROWLEN*sizeof(row_elt)); + } + + OUT->row[i].maxlen = MINROWLEN; + OUT->row[i].len = 0; + } + OUT->m = A->m; + } + + OUT->flag_col = OUT->flag_diag = FALSE; + /* sp_zero(OUT); */ + + for ( i = 0; i < A->m; i++ ) + { + r1 = &(A->row[i]); r2 = &(OUT->row[i]); + sprow_copy(r1,r2,scratch,TYPE_SPROW); + if ( r2->maxlen < scratch->len ) + sprow_xpd(r2,scratch->len,TYPE_SPMAT); + MEM_COPY((char *)(scratch->elt),(char *)(r2->elt), + scratch->len*sizeof(row_elt)); + r2->len = scratch->len; + /******************************************************* + e1 = r1->elt; e2 = r2->elt; + len1 = r1->len; len2 = r2->len; + for ( idx = 0; idx < len2; idx++, e2++ ) + e2->val = 0.0; + for ( idx = 0; idx < len1; idx++, e1++ ) + sprow_set_val(r2,e1->col,e1->val); + *******************************************************/ + } +#ifdef SP_COL_ACCESS + sp_col_access(OUT); +#endif + return OUT; +} + +/* sp_resize -- resize a sparse matrix + -- don't destroying any contents if possible + -- returns resized matrix */ +SPMAT *sp_resize(A,m,n) +SPMAT *A; +int m, n; +{ + int i, len; + SPROW *r; + + if (m < 0 || n < 0) + error(E_NEG,"sp_resize"); + + if ( ! A ) + return sp_get(m,n,10); + + if (m == A->m && n == A->n) + return A; + + if ( m <= A->max_m ) + { + for ( i = A->m; i < m; i++ ) + A->row[i].len = 0; + A->m = m; + } + else + { + if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,A->max_m*sizeof(SPROW), + m*sizeof(SPROW)); + } + + A->row = RENEW(A->row,(unsigned)m,SPROW); + if ( ! A->row ) + error(E_MEM,"sp_resize"); + for ( i = A->m; i < m; i++ ) + { + if ( ! (A->row[i].elt = NEW_A(MINROWLEN,row_elt)) ) + error(E_MEM,"sp_resize"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT,0,MINROWLEN*sizeof(row_elt)); + } + A->row[i].len = 0; A->row[i].maxlen = MINROWLEN; + } + A->m = A->max_m = m; + } + + /* update number of rows */ + A->n = n; + + /* do we need to increase the size of start_idx[] and start_row[] ? */ + if ( n > A->max_n ) + { /* only have to update the start_idx & start_row arrays */ + if (mem_info_is_on()) + { + mem_bytes(TYPE_SPMAT,2*A->max_n*sizeof(int), + 2*n*sizeof(int)); + } + + A->start_row = RENEW(A->start_row,(unsigned)n,int); + A->start_idx = RENEW(A->start_idx,(unsigned)n,int); + if ( ! A->start_row || ! A->start_idx ) + error(E_MEM,"sp_resize"); + A->max_n = n; /* ...and update max_n */ + + return A; + } + + if ( n <= A->n ) + /* make sure that all rows are truncated just before column n */ + for ( i = 0; i < A->m; i++ ) + { + r = &(A->row[i]); + len = sprow_idx(r,n); + if ( len < 0 ) + len = -(len+2); + if ( len < 0 ) + error(E_MEM,"sp_resize"); + r->len = len; + } + + return A; +} + + +/* sp_compact -- removes zeros and near-zeros from a sparse matrix */ +SPMAT *sp_compact(A,tol) +SPMAT *A; +double tol; +{ + int i, idx1, idx2; + SPROW *r; + row_elt *elt1, *elt2; + + if ( ! A ) + error(E_NULL,"sp_compact"); + if ( tol < 0.0 ) + error(E_RANGE,"sp_compact"); + + A->flag_col = A->flag_diag = FALSE; + + for ( i = 0; i < A->m; i++ ) + { + r = &(A->row[i]); + elt1 = elt2 = r->elt; + idx1 = idx2 = 0; + while ( idx1 < r->len ) + { + /* printf("# sp_compact: idx1 = %d, idx2 = %d\n",idx1,idx2); */ + if ( fabs(elt1->val) <= tol ) + { idx1++; elt1++; continue; } + if ( elt1 != elt2 ) + MEM_COPY(elt1,elt2,sizeof(row_elt)); + idx1++; elt1++; + idx2++; elt2++; + } + r->len = idx2; + } + + return A; +} + +/* varying number of arguments */ + +#ifdef ANSI_C + +/* To allocate memory to many arguments. + The function should be called: + sp_get_vars(m,n,deg,&x,&y,&z,...,NULL); + where + int m,n,deg; + SPMAT *x, *y, *z,...; + The last argument should be NULL ! + m x n is the dimension of matrices x,y,z,... + returned value is equal to the number of allocated variables +*/ + +int sp_get_vars(int m,int n,int deg,...) +{ + va_list ap; + int i=0; + SPMAT **par; + + va_start(ap, deg); + while (par = va_arg(ap,SPMAT **)) { /* NULL ends the list*/ + *par = sp_get(m,n,deg); + i++; + } + + va_end(ap); + return i; +} + + +/* To resize memory for many arguments. + The function should be called: + sp_resize_vars(m,n,&x,&y,&z,...,NULL); + where + int m,n; + SPMAT *x, *y, *z,...; + The last argument should be NULL ! + m X n is the resized dimension of matrices x,y,z,... + returned value is equal to the number of allocated variables. + If one of x,y,z,.. arguments is NULL then memory is allocated to this + argument. +*/ + +int sp_resize_vars(int m,int n,...) +{ + va_list ap; + int i=0; + SPMAT **par; + + va_start(ap, n); + while (par = va_arg(ap,SPMAT **)) { /* NULL ends the list*/ + *par = sp_resize(*par,m,n); + i++; + } + + va_end(ap); + return i; +} + +/* To deallocate memory for many arguments. + The function should be called: + sp_free_vars(&x,&y,&z,...,NULL); + where + SPMAT *x, *y, *z,...; + The last argument should be NULL ! + There must be at least one not NULL argument. + returned value is equal to the number of allocated variables. + Returned value of x,y,z,.. is VNULL. +*/ + +int sp_free_vars(SPMAT **va,...) +{ + va_list ap; + int i=1; + SPMAT **par; + + sp_free(*va); + *va = (SPMAT *) NULL; + va_start(ap, va); + while (par = va_arg(ap,SPMAT **)) { /* NULL ends the list*/ + sp_free(*par); + *par = (SPMAT *)NULL; + i++; + } + + va_end(ap); + return i; +} + + +#elif VARARGS + +/* To allocate memory to many arguments. + The function should be called: + sp_get_vars(m,n,deg,&x,&y,&z,...,NULL); + where + int m,n,deg; + SPMAT *x, *y, *z,...; + The last argument should be NULL ! + m x n is the dimension of matrices x,y,z,... + returned value is equal to the number of allocated variables +*/ + +int sp_get_vars(va_alist) va_dcl +{ + va_list ap; + int i=0, m, n, deg; + SPMAT **par; + + va_start(ap); + m = va_arg(ap,int); + n = va_arg(ap,int); + deg = va_arg(ap,int); + while (par = va_arg(ap,SPMAT **)) { /* NULL ends the list*/ + *par = sp_get(m,n,deg); + i++; + } + + va_end(ap); + return i; +} + + +/* To resize memory for many arguments. + The function should be called: + sp_resize_vars(m,n,&x,&y,&z,...,NULL); + where + int m,n; + SPMAT *x, *y, *z,...; + The last argument should be NULL ! + m X n is the resized dimension of matrices x,y,z,... + returned value is equal to the number of allocated variables. + If one of x,y,z,.. arguments is NULL then memory is allocated to this + argument. +*/ + +int sp_resize_vars(va_alist) va_dcl +{ + va_list ap; + int i=0, m, n; + SPMAT **par; + + va_start(ap); + m = va_arg(ap,int); + n = va_arg(ap,int); + while (par = va_arg(ap,SPMAT **)) { /* NULL ends the list*/ + *par = sp_resize(*par,m,n); + i++; + } + + va_end(ap); + return i; +} + + + +/* To deallocate memory for many arguments. + The function should be called: + sp_free_vars(&x,&y,&z,...,NULL); + where + SPMAT *x, *y, *z,...; + The last argument should be NULL ! + There must be at least one not NULL argument. + returned value is equal to the number of allocated variables. + Returned value of x,y,z,.. is VNULL. +*/ + +int sp_free_vars(va_alist) va_dcl +{ + va_list ap; + int i=0; + SPMAT **par; + + va_start(ap); + while (par = va_arg(ap,SPMAT **)) { /* NULL ends the list*/ + sp_free(*par); + *par = (SPMAT *)NULL; + i++; + } + + va_end(ap); + return i; +} + + + +#endif + diff --git a/meschach/sparse2.h b/meschach/sparse2.h new file mode 100644 index 0000000..ac3362e --- /dev/null +++ b/meschach/sparse2.h @@ -0,0 +1,95 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* Sparse matrix factorise/solve header */ +/* RCS id: $Id: sparse2.h,v 1.1 2001/03/01 17:19:02 rfranke Exp $ */ + + + +#ifndef SPARSE2H + +#define SPARSE2H + +#include "sparse.h" + + +#ifdef ANSI_C +SPMAT *spCHfactor(SPMAT *), *spICHfactor(SPMAT *), *spCHsymb(SPMAT *); +VEC *spCHsolve(SPMAT *,VEC *,VEC *); + +SPMAT *spLUfactor(SPMAT *,PERM *,double); +SPMAT *spILUfactor(SPMAT *,double); +VEC *spLUsolve(SPMAT *,PERM *,VEC *,VEC *), + *spLUTsolve(SPMAT *,PERM *,VEC *,VEC *); + +SPMAT *spBKPfactor(SPMAT *, PERM *, PERM *, double); +VEC *spBKPsolve(SPMAT *, PERM *, PERM *, VEC *, VEC *); + +VEC *pccg(VEC *(*A)(),void *A_par,VEC *(*M_inv)(),void *M_par,VEC *b, + double tol,VEC *x); +VEC *sp_pccg(SPMAT *,SPMAT *,VEC *,double,VEC *); +VEC *cgs(VEC *(*A)(),void *A_par,VEC *b,VEC *r0,double tol,VEC *x); +VEC *sp_cgs(SPMAT *,VEC *,VEC *,double,VEC *); +VEC *lsqr(VEC *(*A)(),VEC *(*AT)(),void *A_par,VEC *b,double tol,VEC *x); +VEC *sp_lsqr(SPMAT *,VEC *,double,VEC *); +int cg_set_maxiter(int); + +void lanczos(VEC *(*A)(),void *A_par,int m,VEC *x0,VEC *a,VEC *b, + Real *beta_m1,MAT *Q); +void sp_lanczos(SPMAT *,int,VEC *,VEC *,VEC *,Real *,MAT *); +VEC *lanczos2(VEC *(*A)(),void *A_par,int m,VEC *x0,VEC *evals, + VEC *err_est); +VEC *sp_lanczos2(SPMAT *,int,VEC *,VEC *,VEC *); +extern void scan_to(SPMAT *,IVEC *,IVEC *,IVEC *,int); +extern row_elt *chase_col(SPMAT *,int,int *,int *,int); +extern row_elt *chase_past(SPMAT *,int,int *,int *,int); +extern row_elt *bump_col(SPMAT *,int,int *,int *); + +#else +extern SPMAT *spCHfactor(), *spICHfactor(), *spCHsymb(); +extern VEC *spCHsolve(); + +extern SPMAT *spLUfactor(); +extern SPMAT *spILUfactor(); +extern VEC *spLUsolve(), *spLUTsolve(); + +extern SPMAT *spBKPfactor(); +extern VEC *spBKPsolve(); + +extern VEC *pccg(), *sp_pccg(), *cgs(), *sp_cgs(), *lsqr(), *sp_lsqr(); +extern int cg_set_maxiter(); + +void lanczos(), sp_lanczos(); +VEC *lanczos2(), *sp_lanczos2(); +extern void scan_to(); +extern row_elt *chase_col(); +extern row_elt *chase_past(); +extern row_elt *bump_col(); + +#endif + + +#endif diff --git a/meschach/sparseio.c b/meschach/sparseio.c new file mode 100644 index 0000000..3d25320 --- /dev/null +++ b/meschach/sparseio.c @@ -0,0 +1,320 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + This file has the routines for sparse matrix input/output + It works in conjunction with sparse.c, sparse.h etc +*/ + +#include +#include "sparse.h" + +static char rcsid[] = "$Id: sparseio.c,v 1.1 2001/03/01 17:19:03 rfranke Exp $"; + + + +/* local variables */ +static char line[MAXLINE]; + +/* sp_foutput -- output sparse matrix A to file/stream fp */ +void sp_foutput(fp,A) +FILE *fp; +SPMAT *A; +{ + int i, j_idx, m /* , n */; + SPROW *rows; + row_elt *elts; + + fprintf(fp,"SparseMatrix: "); + if ( A == SMNULL ) + { + fprintf(fp,"*** NULL ***\n"); + error(E_NULL,"sp_foutput"); return; + } + fprintf(fp,"%d by %d\n",A->m,A->n); + m = A->m; /* n = A->n; */ + if ( ! (rows=A->row) ) + { + fprintf(fp,"*** NULL rows ***\n"); + error(E_NULL,"sp_foutput"); return; + } + + for ( i = 0; i < m; i++ ) + { + fprintf(fp,"row %d: ",i); + if ( ! (elts=rows[i].elt) ) + { + fprintf(fp,"*** NULL element list ***\n"); + continue; + } + for ( j_idx = 0; j_idx < rows[i].len; j_idx++ ) + { + fprintf(fp,"%d:%-20.15g ",elts[j_idx].col, + elts[j_idx].val); + if ( j_idx % 3 == 2 && j_idx != rows[i].len-1 ) + fprintf(fp,"\n "); + } + fprintf(fp,"\n"); + } + fprintf(fp,"#\n"); /* to stop looking beyond for next entry */ +} + +/* sp_foutput2 -- print out sparse matrix **as a dense matrix** + -- see output format used in matrix.h etc */ +/****************************************************************** +void sp_foutput2(fp,A) +FILE *fp; +SPMAT *A; +{ + int cnt, i, j, j_idx; + SPROW *r; + row_elt *elt; + + if ( A == SMNULL ) + { + fprintf(fp,"Matrix: *** NULL ***\n"); + return; + } + fprintf(fp,"Matrix: %d by %d\n",A->m,A->n); + for ( i = 0; i < A->m; i++ ) + { + fprintf(fp,"row %d:",i); + r = &(A->row[i]); + elt = r->elt; + cnt = j = j_idx = 0; + while ( j_idx < r->len || j < A->n ) + { + if ( j_idx >= r->len ) + fprintf(fp,"%14.9g ",0.0); + else if ( j < elt[j_idx].col ) + fprintf(fp,"%14.9g ",0.0); + else + fprintf(fp,"%14.9g ",elt[j_idx++].val); + if ( cnt++ % 4 == 3 ) + fprintf(fp,"\n"); + j++; + } + fprintf(fp,"\n"); + } +} +******************************************************************/ + +/* sp_dump -- prints ALL relevant information about the sparse matrix A */ +void sp_dump(fp,A) +FILE *fp; +SPMAT *A; +{ + int i, j, j_idx; + SPROW *rows; + row_elt *elts; + + fprintf(fp,"SparseMatrix dump:\n"); + if ( ! A ) + { fprintf(fp,"*** NULL ***\n"); return; } + fprintf(fp,"Matrix at 0x%lx\n",(long)A); + fprintf(fp,"Dimensions: %d by %d\n",A->m,A->n); + fprintf(fp,"MaxDimensions: %d by %d\n",A->max_m,A->max_n); + fprintf(fp,"flag_col = %d, flag_diag = %d\n",A->flag_col,A->flag_diag); + fprintf(fp,"start_row @ 0x%lx:\n",(long)(A->start_row)); + for ( j = 0; j < A->n; j++ ) + { + fprintf(fp,"%d ",A->start_row[j]); + if ( j % 10 == 9 ) + fprintf(fp,"\n"); + } + fprintf(fp,"\n"); + fprintf(fp,"start_idx @ 0x%lx:\n",(long)(A->start_idx)); + for ( j = 0; j < A->n; j++ ) + { + fprintf(fp,"%d ",A->start_idx[j]); + if ( j % 10 == 9 ) + fprintf(fp,"\n"); + } + fprintf(fp,"\n"); + fprintf(fp,"Rows @ 0x%lx:\n",(long)(A->row)); + if ( ! A->row ) + { fprintf(fp,"*** NULL row ***\n"); return; } + rows = A->row; + for ( i = 0; i < A->m; i++ ) + { + fprintf(fp,"row %d: len = %d, maxlen = %d, diag idx = %d\n", + i,rows[i].len,rows[i].maxlen,rows[i].diag); + fprintf(fp,"element list @ 0x%lx\n",(long)(rows[i].elt)); + if ( ! rows[i].elt ) + { + fprintf(fp,"*** NULL element list ***\n"); + continue; + } + elts = rows[i].elt; + for ( j_idx = 0; j_idx < rows[i].len; j_idx++, elts++ ) +#ifdef SPARSE_COL_ACCESS + fprintf(fp,"Col: %d, Val: %g, nxt_row = %d, nxt_idx = %d\n", + elts->col,elts->val,elts->nxt_row,elts->nxt_idx); +#else + fprintf(fp,"Col: %d, Val: %g\n", + elts->col,elts->val); +#endif + fprintf(fp,"\n"); + } +} + +#define MAXSCRATCH 100 + +/* sp_finput -- input sparse matrix from stream/file fp + -- uses friendly input routine if fp is a tty + -- uses format identical to output format otherwise */ +SPMAT *sp_finput(fp) +FILE *fp; +{ + int i, len, ret_val; + int col, curr_col, m, n, tmp, tty; + Real val; + SPMAT *A; + SPROW *rows; + + row_elt scratch[MAXSCRATCH]; + /* cannot handle >= MAXSCRATCH elements in a row */ +#ifdef SPARSE_COL_ACCESS + for ( i = 0; i < MAXSCRATCH; i++ ) + scratch[i].nxt_row = scratch[i].nxt_idx = -1; +#endif + tty = isatty(fileno(fp)); + + if ( tty ) + { + fprintf(stderr,"SparseMatrix: "); + do { + fprintf(stderr,"input rows cols: "); + if ( ! fgets(line,MAXLINE,fp) ) + error(E_INPUT,"sp_finput"); + } while ( sscanf(line,"%u %u",&m,&n) != 2 ); + A = sp_get(m,n,5); + rows = A->row; + + for ( i = 0; i < m; i++ ) + { + fprintf(stderr,"Row %d:\n",i); + fprintf(stderr,"Enter or 'e' to end row\n"); + curr_col = -1; + for ( len = 0; len < MAXSCRATCH; len++ ) + { + do { + fprintf(stderr,"Entry %d: ",len); + if ( ! fgets(line,MAXLINE,fp) ) + error(E_INPUT,"sp_finput"); + if ( *line == 'e' || *line == 'E' ) + break; +#if REAL == DOUBLE + } while ( sscanf(line,"%u %lf",&col,&val) != 2 || +#elif REAL == FLOAT + } while ( sscanf(line,"%u %f",&col,&val) != 2 || +#endif + col >= n || col <= curr_col ); + + if ( *line == 'e' || *line == 'E' ) + break; + + scratch[len].col = col; + scratch[len].val = val; + curr_col = col; + } + + /* Note: len = # elements in row */ + if ( len > 5 ) + { + if (mem_info_is_on()) { + mem_bytes(TYPE_SPMAT, + A->row[i].maxlen*sizeof(row_elt), + len*sizeof(row_elt)); + } + + rows[i].elt = (row_elt *)realloc((char *)rows[i].elt, + len*sizeof(row_elt)); + rows[i].maxlen = len; + } + MEM_COPY(scratch,rows[i].elt,len*sizeof(row_elt)); + rows[i].len = len; + rows[i].diag = sprow_idx(&(rows[i]),i); + } + } + else /* not tty */ + { + ret_val = 0; + skipjunk(fp); + fscanf(fp,"SparseMatrix:"); + skipjunk(fp); + if ( (ret_val=fscanf(fp,"%u by %u",&m,&n)) != 2 ) + error((ret_val == EOF) ? E_EOF : E_FORMAT,"sp_finput"); + A = sp_get(m,n,5); + + /* initialise start_row */ + for ( i = 0; i < A->n; i++ ) + A->start_row[i] = -1; + + rows = A->row; + for ( i = 0; i < m; i++ ) + { + /* printf("Reading row # %d\n",i); */ + rows[i].diag = -1; + skipjunk(fp); + if ( (ret_val=fscanf(fp,"row %d :",&tmp)) != 1 || + tmp != i ) + error((ret_val == EOF) ? E_EOF : E_FORMAT, + "sp_finput"); + curr_col = -1; + for ( len = 0; len < MAXSCRATCH; len++ ) + { +#if REAL == DOUBLE + if ( (ret_val=fscanf(fp,"%u : %lf",&col,&val)) != 2 ) +#elif REAL == FLOAT + if ( (ret_val=fscanf(fp,"%u : %f",&col,&val)) != 2 ) +#endif + break; + if ( col <= curr_col || col >= n ) + error(E_FORMAT,"sp_finput"); + scratch[len].col = col; + scratch[len].val = val; + } + if ( ret_val == EOF ) + error(E_EOF,"sp_finput"); + + if ( len > rows[i].maxlen ) + { + rows[i].elt = (row_elt *)realloc((char *)rows[i].elt, + len*sizeof(row_elt)); + rows[i].maxlen = len; + } + MEM_COPY(scratch,rows[i].elt,len*sizeof(row_elt)); + rows[i].len = len; + /* printf("Have read row # %d\n",i); */ + rows[i].diag = sprow_idx(&(rows[i]),i); + /* printf("Have set diag index for row # %d\n",i); */ + } + } + + return A; +} + diff --git a/meschach/spbkp.c b/meschach/spbkp.c new file mode 100644 index 0000000..453a4f4 --- /dev/null +++ b/meschach/spbkp.c @@ -0,0 +1,1386 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Sparse matrix Bunch--Kaufman--Parlett factorisation and solve + Radical revision started Thu 05th Nov 1992, 09:36:12 AM + to use Karen George's suggestion of leaving the the row elements unordered + Radical revision completed Mon 07th Dec 1992, 10:59:57 AM +*/ + +static char rcsid[] = "$Id: spbkp.c,v 1.1 2001/03/01 17:19:05 rfranke Exp $"; + +#include +#include +#include "matrix.h" +#include "sparse.h" +#include "sparse2.h" + + +#ifdef MALLOCDECL +#include +#endif + +#define alpha 0.6403882032022076 /* = (1+sqrt(17))/8 */ + + +#define btos(x) ((x) ? "TRUE" : "FALSE") + +/* assume no use of sqr() uses side-effects */ +#define sqr(x) ((x)*(x)) + +/* unord_get_idx -- returns index (encoded if entry not allocated) + of the element of row r with column j + -- uses linear search */ +int unord_get_idx(r,j) +SPROW *r; +int j; +{ + int idx; + row_elt *e; + + if ( ! r || ! r->elt ) + error(E_NULL,"unord_get_idx"); + for ( idx = 0, e = r->elt; idx < r->len; idx++, e++ ) + if ( e->col == j ) + break; + if ( idx >= r->len ) + return -(r->len+2); + else + return idx; +} + +/* unord_get_val -- returns value of the (i,j) entry of A + -- same assumptions as unord_get_idx() */ +double unord_get_val(A,i,j) +SPMAT *A; +int i, j; +{ + SPROW *r; + int idx; + + if ( ! A ) + error(E_NULL,"unord_get_val"); + if ( i < 0 || i >= A->m || j < 0 || j >= A->n ) + error(E_BOUNDS,"unord_get_val"); + + r = &(A->row[i]); + idx = unord_get_idx(r,j); + if ( idx < 0 ) + return 0.0; + else + return r->elt[idx].val; +} + + +/* bkp_swap_elt -- swaps the (i,j) with the (k,l) entry of sparse matrix + -- either or both of the entries may be unallocated */ +static SPMAT *bkp_swap_elt(A,i1,j1,idx1,i2,j2,idx2) +SPMAT *A; +int i1, j1, idx1, i2, j2, idx2; +{ + int tmp_row, tmp_idx; + SPROW *r1, *r2; + row_elt *e1, *e2; + Real tmp; + + if ( ! A ) + error(E_NULL,"bkp_swap_elt"); + + if ( i1 < 0 || j1 < 0 || i2 < 0 || j2 < 0 || + i1 >= A->m || j1 >= A->n || i2 >= A->m || j2 >= A->n ) + { + error(E_BOUNDS,"bkp_swap_elt"); + } + + if ( i1 == i2 && j1 == j2 ) + return A; + if ( idx1 < 0 && idx2 < 0 ) /* neither allocated */ + return A; + + r1 = &(A->row[i1]); r2 = &(A->row[i2]); + /* if ( idx1 >= r1->len || idx2 >= r2->len ) + error(E_BOUNDS,"bkp_swap_elt"); */ + if ( idx1 < 0 ) /* assume not allocated */ + { + idx1 = r1->len; + if ( idx1 >= r1->maxlen ) + { tracecatch(sprow_xpd(r1,2*r1->maxlen+1,TYPE_SPMAT), + "bkp_swap_elt"); } + r1->len = idx1+1; + r1->elt[idx1].col = j1; + r1->elt[idx1].val = 0.0; + /* now patch up column access path */ + tmp_row = -1; tmp_idx = j1; + chase_col(A,j1,&tmp_row,&tmp_idx,i1-1); + + if ( tmp_row < 0 ) + { + r1->elt[idx1].nxt_row = A->start_row[j1]; + r1->elt[idx1].nxt_idx = A->start_idx[j1]; + A->start_row[j1] = i1; + A->start_idx[j1] = idx1; + } + else + { + row_elt *tmp_e; + + tmp_e = &(A->row[tmp_row].elt[tmp_idx]); + r1->elt[idx1].nxt_row = tmp_e->nxt_row; + r1->elt[idx1].nxt_idx = tmp_e->nxt_idx; + tmp_e->nxt_row = i1; + tmp_e->nxt_idx = idx1; + } + } + else if ( r1->elt[idx1].col != j1 ) + error(E_INTERN,"bkp_swap_elt"); + if ( idx2 < 0 ) + { + idx2 = r2->len; + if ( idx2 >= r2->maxlen ) + { tracecatch(sprow_xpd(r2,2*r2->maxlen+1,TYPE_SPMAT), + "bkp_swap_elt"); } + + r2->len = idx2+1; + r2->elt[idx2].col = j2; + r2->elt[idx2].val = 0.0; + /* now patch up column access path */ + tmp_row = -1; tmp_idx = j2; + chase_col(A,j2,&tmp_row,&tmp_idx,i2-1); + if ( tmp_row < 0 ) + { + r2->elt[idx2].nxt_row = A->start_row[j2]; + r2->elt[idx2].nxt_idx = A->start_idx[j2]; + A->start_row[j2] = i2; + A->start_idx[j2] = idx2; + } + else + { + row_elt *tmp_e; + + tmp_e = &(A->row[tmp_row].elt[tmp_idx]); + r2->elt[idx2].nxt_row = tmp_e->nxt_row; + r2->elt[idx2].nxt_idx = tmp_e->nxt_idx; + tmp_e->nxt_row = i2; + tmp_e->nxt_idx = idx2; + } + } + else if ( r2->elt[idx2].col != j2 ) + error(E_INTERN,"bkp_swap_elt"); + + e1 = &(r1->elt[idx1]); e2 = &(r2->elt[idx2]); + + tmp = e1->val; + e1->val = e2->val; + e2->val = tmp; + + return A; +} + +/* bkp_bump_col -- bumps row and idx to next entry in column j */ +row_elt *bkp_bump_col(A, j, row, idx) +SPMAT *A; +int j, *row, *idx; +{ + SPROW *r; + row_elt *e; + + if ( *row < 0 ) + { + *row = A->start_row[j]; + *idx = A->start_idx[j]; + } + else + { + r = &(A->row[*row]); + e = &(r->elt[*idx]); + if ( e->col != j ) + error(E_INTERN,"bkp_bump_col"); + *row = e->nxt_row; + *idx = e->nxt_idx; + } + if ( *row < 0 ) + return (row_elt *)NULL; + else + return &(A->row[*row].elt[*idx]); +} + +/* bkp_interchange -- swap rows/cols i and j (symmetric pivot) + -- uses just the upper triangular part */ +SPMAT *bkp_interchange(A, i1, i2) +SPMAT *A; +int i1, i2; +{ + int tmp_row, tmp_idx; + int row1, row2, idx1, idx2, tmp_row1, tmp_idx1, tmp_row2, tmp_idx2; + SPROW *r1, *r2; + row_elt *e1, *e2; + IVEC *done_list = IVNULL; + + if ( ! A ) + error(E_NULL,"bkp_interchange"); + if ( i1 < 0 || i1 >= A->n || i2 < 0 || i2 >= A->n ) + error(E_BOUNDS,"bkp_interchange"); + if ( A->m != A->n ) + error(E_SQUARE,"bkp_interchange"); + + if ( i1 == i2 ) + return A; + if ( i1 > i2 ) + { tmp_idx = i1; i1 = i2; i2 = tmp_idx; } + + done_list = iv_resize(done_list,A->n); + for ( tmp_idx = 0; tmp_idx < A->n; tmp_idx++ ) + done_list->ive[tmp_idx] = FALSE; + row1 = -1; idx1 = i1; + row2 = -1; idx2 = i2; + e1 = bkp_bump_col(A,i1,&row1,&idx1); + e2 = bkp_bump_col(A,i2,&row2,&idx2); + + while ( (row1 >= 0 && row1 < i1) || (row2 >= 0 && row2 < i1) ) + /* Note: "row2 < i1" not "row2 < i2" as we must stop before the + "knee bend" */ + { + if ( row1 >= 0 && row1 < i1 && ( row1 < row2 || row2 < 0 ) ) + { + tmp_row1 = row1; tmp_idx1 = idx1; + e1 = bkp_bump_col(A,i1,&tmp_row1,&tmp_idx1); + if ( ! done_list->ive[row1] ) + { + if ( row1 == row2 ) + bkp_swap_elt(A,row1,i1,idx1,row1,i2,idx2); + else + bkp_swap_elt(A,row1,i1,idx1,row1,i2,-1); + done_list->ive[row1] = TRUE; + } + row1 = tmp_row1; idx1 = tmp_idx1; + } + else if ( row2 >= 0 && row2 < i1 && ( row2 < row1 || row1 < 0 ) ) + { + tmp_row2 = row2; tmp_idx2 = idx2; + e2 = bkp_bump_col(A,i2,&tmp_row2,&tmp_idx2); + if ( ! done_list->ive[row2] ) + { + if ( row1 == row2 ) + bkp_swap_elt(A,row2,i1,idx1,row2,i2,idx2); + else + bkp_swap_elt(A,row2,i1,-1,row2,i2,idx2); + done_list->ive[row2] = TRUE; + } + row2 = tmp_row2; idx2 = tmp_idx2; + } + else if ( row1 == row2 ) + { + tmp_row1 = row1; tmp_idx1 = idx1; + e1 = bkp_bump_col(A,i1,&tmp_row1,&tmp_idx1); + tmp_row2 = row2; tmp_idx2 = idx2; + e2 = bkp_bump_col(A,i2,&tmp_row2,&tmp_idx2); + if ( ! done_list->ive[row1] ) + { + bkp_swap_elt(A,row1,i1,idx1,row2,i2,idx2); + done_list->ive[row1] = TRUE; + } + row1 = tmp_row1; idx1 = tmp_idx1; + row2 = tmp_row2; idx2 = tmp_idx2; + } + } + + /* ensure we are **past** the first knee */ + while ( row2 >= 0 && row2 <= i1 ) + e2 = bkp_bump_col(A,i2,&row2,&idx2); + + /* at/after 1st "knee bend" */ + r1 = &(A->row[i1]); + idx1 = 0; + e1 = &(r1->elt[idx1]); + while ( row2 >= 0 && row2 < i2 ) + { + /* used for update of e2 at end of loop */ + tmp_row = row2; tmp_idx = idx2; + if ( ! done_list->ive[row2] ) + { + r2 = &(A->row[row2]); + bkp_bump_col(A,i2,&tmp_row,&tmp_idx); + done_list->ive[row2] = TRUE; + tmp_idx1 = unord_get_idx(r1,row2); + tracecatch(bkp_swap_elt(A,row2,i2,idx2,i1,row2,tmp_idx1), + "bkp_interchange"); + } + + /* update e1 and e2 */ + row2 = tmp_row; idx2 = tmp_idx; + e2 = ( row2 >= 0 ) ? &(A->row[row2].elt[idx2]) : (row_elt *)NULL; + } + + idx1 = 0; + e1 = r1->elt; + while ( idx1 < r1->len ) + { + if ( e1->col >= i2 || e1->col <= i1 ) + { + idx1++; + e1++; + continue; + } + if ( ! done_list->ive[e1->col] ) + { + tmp_idx2 = unord_get_idx(&(A->row[e1->col]),i2); + tracecatch(bkp_swap_elt(A,i1,e1->col,idx1,e1->col,i2,tmp_idx2), + "bkp_interchange"); + done_list->ive[e1->col] = TRUE; + } + idx1++; + e1++; + } + + /* at/after 2nd "knee bend" */ + idx1 = 0; + e1 = &(r1->elt[idx1]); + r2 = &(A->row[i2]); + idx2 = 0; + e2 = &(r2->elt[idx2]); + while ( idx1 < r1->len ) + { + if ( e1->col <= i2 ) + { + idx1++; e1++; + continue; + } + if ( ! done_list->ive[e1->col] ) + { + tmp_idx2 = unord_get_idx(r2,e1->col); + tracecatch(bkp_swap_elt(A,i1,e1->col,idx1,i2,e1->col,tmp_idx2), + "bkp_interchange"); + done_list->ive[e1->col] = TRUE; + } + idx1++; e1++; + } + + idx2 = 0; e2 = r2->elt; + while ( idx2 < r2->len ) + { + if ( e2->col <= i2 ) + { + idx2++; e2++; + continue; + } + if ( ! done_list->ive[e2->col] ) + { + tmp_idx1 = unord_get_idx(r1,e2->col); + tracecatch(bkp_swap_elt(A,i2,e2->col,idx2,i1,e2->col,tmp_idx1), + "bkp_interchange"); + done_list->ive[e2->col] = TRUE; + } + idx2++; e2++; + } + + /* now interchange the digonal entries! */ + idx1 = unord_get_idx(&(A->row[i1]),i1); + idx2 = unord_get_idx(&(A->row[i2]),i2); + if ( idx1 >= 0 || idx2 >= 0 ) + { + tracecatch(bkp_swap_elt(A,i1,i1,idx1,i2,i2,idx2), + "bkp_interchange"); + } + + return A; +} + + +/* iv_min -- returns minimum of an integer vector + -- sets index to the position in iv if index != NULL */ +int iv_min(iv,index) +IVEC *iv; +int *index; +{ + int i, i_min, min_val, tmp; + + if ( ! iv ) + error(E_NULL,"iv_min"); + if ( iv->dim <= 0 ) + error(E_SIZES,"iv_min"); + i_min = 0; + min_val = iv->ive[0]; + for ( i = 1; i < iv->dim; i++ ) + { + tmp = iv->ive[i]; + if ( tmp < min_val ) + { + min_val = tmp; + i_min = i; + } + } + + if ( index != (int *)NULL ) + *index = i_min; + + return min_val; +} + +/* max_row_col -- returns max { |A[j][k]| : k >= i, k != j, k != l } given j + using symmetry and only the upper triangular part of A */ +static double max_row_col(A,i,j,l) +SPMAT *A; +int i, j, l; +{ + int row_num, idx; + SPROW *r; + row_elt *e; + Real max_val, tmp; + + if ( ! A ) + error(E_NULL,"max_row_col"); + if ( i < 0 || i > A->n || j < 0 || j >= A->n ) + error(E_BOUNDS,"max_row_col"); + + max_val = 0.0; + + idx = unord_get_idx(&(A->row[i]),j); + if ( idx < 0 ) + { + row_num = -1; idx = j; + e = chase_past(A,j,&row_num,&idx,i); + } + else + { + row_num = i; + e = &(A->row[i].elt[idx]); + } + while ( row_num >= 0 && row_num < j ) + { + if ( row_num != l ) + { + tmp = fabs(e->val); + if ( tmp > max_val ) + max_val = tmp; + } + e = bump_col(A,j,&row_num,&idx); + } + r = &(A->row[j]); + for ( idx = 0, e = r->elt; idx < r->len; idx++, e++ ) + { + if ( e->col > j && e->col != l ) + { + tmp = fabs(e->val); + if ( tmp > max_val ) + max_val = tmp; + } + } + + return max_val; +} + +/* nonzeros -- counts non-zeros in A */ +static int nonzeros(A) +SPMAT *A; +{ + int cnt, i; + + if ( ! A ) + return 0; + cnt = 0; + for ( i = 0; i < A->m; i++ ) + cnt += A->row[i].len; + + return cnt; +} + +/* chk_col_access -- for spBKPfactor() + -- checks that column access path is OK */ +int chk_col_access(A) +SPMAT *A; +{ + int cnt_nz, j, row, idx; + SPROW *r; + row_elt *e; + + if ( ! A ) + error(E_NULL,"chk_col_access"); + + /* count nonzeros as we go down columns */ + cnt_nz = 0; + for ( j = 0; j < A->n; j++ ) + { + row = A->start_row[j]; + idx = A->start_idx[j]; + while ( row >= 0 ) + { + if ( row >= A->m || idx < 0 ) + return FALSE; + r = &(A->row[row]); + if ( idx >= r->len ) + return FALSE; + e = &(r->elt[idx]); + if ( e->nxt_row >= 0 && e->nxt_row <= row ) + return FALSE; + row = e->nxt_row; + idx = e->nxt_idx; + cnt_nz++; + } + } + + if ( cnt_nz != nonzeros(A) ) + return FALSE; + else + return TRUE; +} + +/* col_cmp -- compare two columns -- for sorting rows using qsort() */ +static int col_cmp(e1,e2) +row_elt *e1, *e2; +{ + return e1->col - e2->col; +} + +/* spBKPfactor -- sparse Bunch-Kaufman-Parlett factorisation of A in-situ + -- A is factored into the form P'AP = MDM' where + P is a permutation matrix, M lower triangular and D is block + diagonal with blocks of size 1 or 2 + -- P is stored in pivot; blocks[i]==i iff D[i][i] is a block */ +SPMAT *spBKPfactor(A,pivot,blocks,tol) +SPMAT *A; +PERM *pivot, *blocks; +double tol; +{ + int i, j, k, l, n, onebyone, r; + int idx, idx1, idx_piv; + int row_num; + int best_deg, best_j, best_l, best_cost, mark_cost, deg, deg_j, + deg_l, ignore_deg; + int list_idx, list_idx2, old_list_idx; + SPROW *row, *r_piv, *r1_piv; + row_elt *e, *e1; + Real aii, aip1, aip1i; + Real det, max_j, max_l, s, t; + static IVEC *scan_row = IVNULL, *scan_idx = IVNULL, *col_list = IVNULL, + *tmp_iv = IVNULL; + static IVEC *deg_list = IVNULL; + static IVEC *orig_idx = IVNULL, *orig1_idx = IVNULL; + static PERM *order = PNULL; + + if ( ! A || ! pivot || ! blocks ) + error(E_NULL,"spBKPfactor"); + if ( A->m != A->n ) + error(E_SQUARE,"spBKPfactor"); + if ( A->m != pivot->size || pivot->size != blocks->size ) + error(E_SIZES,"spBKPfactor"); + if ( tol <= 0.0 || tol > 1.0 ) + error(E_RANGE,"spBKPfactor"); + + n = A->n; + + px_ident(pivot); px_ident(blocks); + sp_col_access(A); sp_diag_access(A); + ignore_deg = FALSE; + + deg_list = iv_resize(deg_list,n); + order = px_resize(order,n); + MEM_STAT_REG(deg_list,TYPE_IVEC); + MEM_STAT_REG(order,TYPE_PERM); + + scan_row = iv_resize(scan_row,5); + scan_idx = iv_resize(scan_idx,5); + col_list = iv_resize(col_list,5); + orig_idx = iv_resize(orig_idx,5); + orig_idx = iv_resize(orig1_idx,5); + orig_idx = iv_resize(tmp_iv,5); + MEM_STAT_REG(scan_row,TYPE_IVEC); + MEM_STAT_REG(scan_idx,TYPE_IVEC); + MEM_STAT_REG(col_list,TYPE_IVEC); + MEM_STAT_REG(orig_idx,TYPE_IVEC); + MEM_STAT_REG(orig1_idx,TYPE_IVEC); + MEM_STAT_REG(tmp_iv,TYPE_IVEC); + + for ( i = 0; i < n-1; i = onebyone ? i+1 : i+2 ) + { + /* now we want to use a Markowitz-style selection rule for + determining which rows to swap and whether to use + 1x1 or 2x2 pivoting */ + + /* get list of degrees of nodes */ + deg_list = iv_resize(deg_list,n-i); + if ( ! ignore_deg ) + for ( j = i; j < n; j++ ) + deg_list->ive[j-i] = 0; + else + { + for ( j = i; j < n; j++ ) + deg_list->ive[j-i] = 1; + if ( i < n ) + deg_list->ive[0] = 0; + } + order = px_resize(order,n-i); + px_ident(order); + + if ( ! ignore_deg ) + { + for ( j = i; j < n; j++ ) + { + /* idx = sprow_idx(&(A->row[j]),j+1); */ + /* idx = fixindex(idx); */ + idx = 0; + row = &(A->row[j]); + e = &(row->elt[idx]); + /* deg_list->ive[j-i] += row->len - idx; */ + for ( ; idx < row->len; idx++, e++ ) + if ( e->col >= i ) + deg_list->ive[e->col - i]++; + } + /* now deg_list[k] == degree of node k+i */ + + /* now sort them into increasing order */ + iv_sort(deg_list,order); + /* now deg_list[idx] == degree of node i+order[idx] */ + } + + /* now we can chase through the nodes in order of increasing + degree, picking out the ones that satisfy our stability + criterion */ + list_idx = 0; r = -1; + best_j = best_l = -1; + for ( deg = 0; deg <= n; deg++ ) + { + Real ajj, all, ajl; + + if ( list_idx >= deg_list->dim ) + break; /* That's all folks! */ + old_list_idx = list_idx; + while ( list_idx < deg_list->dim && + deg_list->ive[list_idx] <= deg ) + { + j = i+order->pe[list_idx]; + if ( j < i ) + continue; + /* can we use row/col j for a 1 x 1 pivot? */ + /* find max_j = max_{k>=i} {|A[k][j]|,|A[j][k]|} */ + ajj = fabs(unord_get_val(A,j,j)); + if ( ajj == 0.0 ) + { + list_idx++; + continue; /* can't use this for 1 x 1 pivot */ + } + + max_j = max_row_col(A,i,j,-1); + if ( ajj >= tol/* *alpha */ *max_j ) + { + onebyone = TRUE; + best_j = j; + best_deg = deg_list->ive[list_idx]; + break; + } + list_idx++; + } + if ( best_j >= 0 ) + break; + best_cost = 2*n; /* > any possible Markowitz cost (bound) */ + best_j = best_l = -1; + list_idx = old_list_idx; + while ( list_idx < deg_list->dim && + deg_list->ive[list_idx] <= deg ) + { + j = i+order->pe[list_idx]; + ajj = fabs(unord_get_val(A,j,j)); + for ( list_idx2 = 0; list_idx2 < list_idx; list_idx2++ ) + { + deg_j = deg; + deg_l = deg_list->ive[list_idx2]; + l = i+order->pe[list_idx2]; + if ( l < i ) + continue; + /* try using rows/cols (j,l) for a 2 x 2 pivot block */ + all = fabs(unord_get_val(A,l,l)); + ajl = ( j > l ) ? fabs(unord_get_val(A,l,j)) : + fabs(unord_get_val(A,j,l)); + det = fabs(ajj*all - ajl*ajl); + if ( det == 0.0 ) + continue; + max_j = max_row_col(A,i,j,l); + max_l = max_row_col(A,i,l,j); + if ( tol*(all*max_j+ajl*max_l) < det && + tol*(ajl*max_j+ajj*max_l) < det ) + { + /* acceptably stable 2 x 2 pivot */ + /* this is actually an overestimate of the + Markowitz cost for choosing (j,l) */ + mark_cost = (ajj == 0.0) ? + ((all == 0.0) ? deg_j+deg_l : deg_j+2*deg_l) : + ((all == 0.0) ? 2*deg_j+deg_l : + 2*(deg_j+deg_l)); + if ( mark_cost < best_cost ) + { + onebyone = FALSE; + best_cost = mark_cost; + best_j = j; + best_l = l; + best_deg = deg_j; + } + } + } + list_idx++; + } + if ( best_j >= 0 ) + break; + } + + if ( best_deg > (int)floor(0.8*(n-i)) ) + ignore_deg = TRUE; + + /* now do actual interchanges */ + if ( best_j >= 0 && onebyone ) + { + bkp_interchange(A,i,best_j); + px_transp(pivot,i,best_j); + } + else if ( best_j >= 0 && best_l >= 0 && ! onebyone ) + { + if ( best_j == i || best_j == i+1 ) + { + if ( best_l == i || best_l == i+1 ) + { + /* no pivoting, but must update blocks permutation */ + px_transp(blocks,i,i+1); + goto dopivot; + } + bkp_interchange(A,(best_j == i) ? i+1 : i,best_l); + px_transp(pivot,(best_j == i) ? i+1 : i,best_l); + } + else if ( best_l == i || best_l == i+1 ) + { + bkp_interchange(A,(best_l == i) ? i+1 : i,best_j); + px_transp(pivot,(best_l == i) ? i+1 : i,best_j); + } + else /* best_j & best_l outside i, i+1 */ + { + if ( i != best_j ) + { + bkp_interchange(A,i,best_j); + px_transp(pivot,i,best_j); + } + if ( i+1 != best_l ) + { + bkp_interchange(A,i+1,best_l); + px_transp(pivot,i+1,best_l); + } + } + } + else /* can't pivot &/or nothing to pivot */ + continue; + + /* update blocks permutation */ + if ( ! onebyone ) + px_transp(blocks,i,i+1); + + dopivot: + if ( onebyone ) + { + int idx_j, idx_k, s_idx, s_idx2; + row_elt *e_ij, *e_ik; + + r_piv = &(A->row[i]); + idx_piv = unord_get_idx(r_piv,i); + /* if idx_piv < 0 then aii == 0 and no pivoting can be done; + -- this means that we should continue to the next iteration */ + if ( idx_piv < 0 ) + continue; + aii = r_piv->elt[idx_piv].val; + if ( aii == 0.0 ) + continue; + + /* for ( j = i+1; j < n; j++ ) { ... pivot step ... } */ + /* initialise scan_... etc for the 1 x 1 pivot */ + scan_row = iv_resize(scan_row,r_piv->len); + scan_idx = iv_resize(scan_idx,r_piv->len); + col_list = iv_resize(col_list,r_piv->len); + orig_idx = iv_resize(orig_idx,r_piv->len); + row_num = i; s_idx = idx = 0; + e = &(r_piv->elt[idx]); + for ( idx = 0; idx < r_piv->len; idx++, e++ ) + { + if ( e->col < i ) + continue; + scan_row->ive[s_idx] = i; + scan_idx->ive[s_idx] = idx; + orig_idx->ive[s_idx] = idx; + col_list->ive[s_idx] = e->col; + s_idx++; + } + scan_row = iv_resize(scan_row,s_idx); + scan_idx = iv_resize(scan_idx,s_idx); + col_list = iv_resize(col_list,s_idx); + orig_idx = iv_resize(orig_idx,s_idx); + + order = px_resize(order,scan_row->dim); + px_ident(order); + iv_sort(col_list,order); + + tmp_iv = iv_resize(tmp_iv,scan_row->dim); + for ( idx = 0; idx < order->size; idx++ ) + tmp_iv->ive[idx] = scan_idx->ive[order->pe[idx]]; + iv_copy(tmp_iv,scan_idx); + for ( idx = 0; idx < order->size; idx++ ) + tmp_iv->ive[idx] = scan_row->ive[order->pe[idx]]; + iv_copy(tmp_iv,scan_row); + for ( idx = 0; idx < scan_row->dim; idx++ ) + tmp_iv->ive[idx] = orig_idx->ive[order->pe[idx]]; + iv_copy(tmp_iv,orig_idx); + + /* now do actual pivot */ + /* for ( j = i+1; j < n-1; j++ ) .... */ + + for ( s_idx = 0; s_idx < scan_row->dim; s_idx++ ) + { + idx_j = orig_idx->ive[s_idx]; + if ( idx_j < 0 ) + error(E_INTERN,"spBKPfactor"); + e_ij = &(r_piv->elt[idx_j]); + j = e_ij->col; + if ( j < i+1 ) + continue; + scan_to(A,scan_row,scan_idx,col_list,j); + + /* compute multiplier */ + t = e_ij->val / aii; + + /* for ( k = j; k < n; k++ ) { .... update A[j][k] .... } */ + /* this is the row in which pivoting is done */ + row = &(A->row[j]); + for ( s_idx2 = s_idx; s_idx2 < scan_row->dim; s_idx2++ ) + { + idx_k = orig_idx->ive[s_idx2]; + e_ik = &(r_piv->elt[idx_k]); + k = e_ik->col; + /* k >= j since col_list has been sorted */ + + if ( scan_row->ive[s_idx2] == j ) + { /* no fill-in -- can be done directly */ + idx = scan_idx->ive[s_idx2]; + /* idx = sprow_idx2(row,k,idx); */ + row->elt[idx].val -= t*e_ik->val; + } + else + { /* fill-in -- insert entry & patch column */ + int old_row, old_idx; + row_elt *old_e, *new_e; + + old_row = scan_row->ive[s_idx2]; + old_idx = scan_idx->ive[s_idx2]; + /* old_idx = sprow_idx2(&(A->row[old_row]),k,old_idx); */ + + if ( old_idx < 0 ) + error(E_INTERN,"spBKPfactor"); + /* idx = sprow_idx(row,k); */ + /* idx = fixindex(idx); */ + idx = row->len; + + /* sprow_set_val(row,k,-t*e_ik->val); */ + if ( row->len >= row->maxlen ) + { tracecatch(sprow_xpd(row,2*row->maxlen+1,TYPE_SPMAT), + "spBKPfactor"); } + + row->len = idx+1; + + new_e = &(row->elt[idx]); + new_e->val = -t*e_ik->val; + new_e->col = k; + + old_e = &(A->row[old_row].elt[old_idx]); + new_e->nxt_row = old_e->nxt_row; + new_e->nxt_idx = old_e->nxt_idx; + old_e->nxt_row = j; + old_e->nxt_idx = idx; + } + } + e_ij->val = t; + } + } + else /* onebyone == FALSE */ + { /* do 2 x 2 pivot */ + int idx_k, idx1_k, s_idx, s_idx2; + int old_col; + row_elt *e_tmp; + + r_piv = &(A->row[i]); + idx_piv = unord_get_idx(r_piv,i); + aii = aip1i = 0.0; + e_tmp = r_piv->elt; + for ( idx_piv = 0; idx_piv < r_piv->len; idx_piv++, e_tmp++ ) + if ( e_tmp->col == i ) + aii = e_tmp->val; + else if ( e_tmp->col == i+1 ) + aip1i = e_tmp->val; + + r1_piv = &(A->row[i+1]); + e_tmp = r1_piv->elt; + aip1 = unord_get_val(A,i+1,i+1); + det = aii*aip1 - aip1i*aip1i; /* Must have det < 0 */ + if ( aii == 0.0 && aip1i == 0.0 ) + { + /* error(E_RANGE,"spBKPfactor"); */ + onebyone = TRUE; + continue; /* cannot pivot */ + } + + if ( det == 0.0 ) + { + if ( aii != 0.0 ) + error(E_RANGE,"spBKPfactor"); + onebyone = TRUE; + continue; /* cannot pivot */ + } + aip1i = aip1i/det; + aii = aii/det; + aip1 = aip1/det; + + /* initialise scan_... etc for the 2 x 2 pivot */ + s_idx = r_piv->len + r1_piv->len; + scan_row = iv_resize(scan_row,s_idx); + scan_idx = iv_resize(scan_idx,s_idx); + col_list = iv_resize(col_list,s_idx); + orig_idx = iv_resize(orig_idx,s_idx); + orig1_idx = iv_resize(orig1_idx,s_idx); + + e = r_piv->elt; + for ( idx = 0; idx < r_piv->len; idx++, e++ ) + { + scan_row->ive[idx] = i; + scan_idx->ive[idx] = idx; + col_list->ive[idx] = e->col; + orig_idx->ive[idx] = idx; + orig1_idx->ive[idx] = -1; + } + e = r_piv->elt; + e1 = r1_piv->elt; + for ( idx = 0; idx < r1_piv->len; idx++, e1++ ) + { + scan_row->ive[idx+r_piv->len] = i+1; + scan_idx->ive[idx+r_piv->len] = idx; + col_list->ive[idx+r_piv->len] = e1->col; + orig_idx->ive[idx+r_piv->len] = -1; + orig1_idx->ive[idx+r_piv->len] = idx; + } + + e1 = r1_piv->elt; + order = px_resize(order,scan_row->dim); + px_ident(order); + iv_sort(col_list,order); + tmp_iv = iv_resize(tmp_iv,scan_row->dim); + for ( idx = 0; idx < order->size; idx++ ) + tmp_iv->ive[idx] = scan_idx->ive[order->pe[idx]]; + iv_copy(tmp_iv,scan_idx); + for ( idx = 0; idx < order->size; idx++ ) + tmp_iv->ive[idx] = scan_row->ive[order->pe[idx]]; + iv_copy(tmp_iv,scan_row); + for ( idx = 0; idx < scan_row->dim; idx++ ) + tmp_iv->ive[idx] = orig_idx->ive[order->pe[idx]]; + iv_copy(tmp_iv,orig_idx); + for ( idx = 0; idx < scan_row->dim; idx++ ) + tmp_iv->ive[idx] = orig1_idx->ive[order->pe[idx]]; + iv_copy(tmp_iv,orig1_idx); + + s_idx = 0; + old_col = -1; + for ( idx = 0; idx < scan_row->dim; idx++ ) + { + if ( col_list->ive[idx] == old_col ) + { + if ( scan_row->ive[idx] == i ) + { + scan_row->ive[s_idx-1] = scan_row->ive[idx]; + scan_idx->ive[s_idx-1] = scan_idx->ive[idx]; + col_list->ive[s_idx-1] = col_list->ive[idx]; + orig_idx->ive[s_idx-1] = orig_idx->ive[idx]; + orig1_idx->ive[s_idx-1] = orig1_idx->ive[idx-1]; + } + else if ( idx > 0 ) + { + scan_row->ive[s_idx-1] = scan_row->ive[idx-1]; + scan_idx->ive[s_idx-1] = scan_idx->ive[idx-1]; + col_list->ive[s_idx-1] = col_list->ive[idx-1]; + orig_idx->ive[s_idx-1] = orig_idx->ive[idx-1]; + orig1_idx->ive[s_idx-1] = orig1_idx->ive[idx]; + } + } + else + { + scan_row->ive[s_idx] = scan_row->ive[idx]; + scan_idx->ive[s_idx] = scan_idx->ive[idx]; + col_list->ive[s_idx] = col_list->ive[idx]; + orig_idx->ive[s_idx] = orig_idx->ive[idx]; + orig1_idx->ive[s_idx] = orig1_idx->ive[idx]; + s_idx++; + } + old_col = col_list->ive[idx]; + } + scan_row = iv_resize(scan_row,s_idx); + scan_idx = iv_resize(scan_idx,s_idx); + col_list = iv_resize(col_list,s_idx); + orig_idx = iv_resize(orig_idx,s_idx); + orig1_idx = iv_resize(orig1_idx,s_idx); + + /* for ( j = i+2; j < n; j++ ) { .... row operation .... } */ + for ( s_idx = 0; s_idx < scan_row->dim; s_idx++ ) + { + int idx_piv, idx1_piv; + Real aip1j, aij, aik, aip1k; + row_elt *e_ik, *e_ip1k; + + j = col_list->ive[s_idx]; + if ( j < i+2 ) + continue; + tracecatch(scan_to(A,scan_row,scan_idx,col_list,j), + "spBKPfactor"); + + idx_piv = orig_idx->ive[s_idx]; + aij = ( idx_piv < 0 ) ? 0.0 : r_piv->elt[idx_piv].val; + /* aij = ( s_idx < r_piv->len ) ? r_piv->elt[s_idx].val : + 0.0; */ + /* aij = sp_get_val(A,i,j); */ + idx1_piv = orig1_idx->ive[s_idx]; + aip1j = ( idx1_piv < 0 ) ? 0.0 : r1_piv->elt[idx1_piv].val; + /* aip1j = ( s_idx < r_piv->len ) ? 0.0 : + r1_piv->elt[s_idx-r_piv->len].val; */ + /* aip1j = sp_get_val(A,i+1,j); */ + s = - aip1i*aip1j + aip1*aij; + t = - aip1i*aij + aii*aip1j; + + /* for ( k = j; k < n; k++ ) { .... update entry .... } */ + row = &(A->row[j]); + /* set idx_k and idx1_k indices */ + s_idx2 = s_idx; + k = col_list->ive[s_idx2]; + idx_k = orig_idx->ive[s_idx2]; + idx1_k = orig1_idx->ive[s_idx2]; + + while ( s_idx2 < scan_row->dim ) + { + k = col_list->ive[s_idx2]; + idx_k = orig_idx->ive[s_idx2]; + idx1_k = orig1_idx->ive[s_idx2]; + e_ik = ( idx_k < 0 ) ? (row_elt *)NULL : + &(r_piv->elt[idx_k]); + e_ip1k = ( idx1_k < 0 ) ? (row_elt *)NULL : + &(r1_piv->elt[idx1_k]); + aik = ( idx_k >= 0 ) ? e_ik->val : 0.0; + aip1k = ( idx1_k >= 0 ) ? e_ip1k->val : 0.0; + if ( scan_row->ive[s_idx2] == j ) + { /* no fill-in */ + row = &(A->row[j]); + /* idx = sprow_idx(row,k); */ + idx = scan_idx->ive[s_idx2]; + if ( idx < 0 ) + error(E_INTERN,"spBKPfactor"); + row->elt[idx].val -= s*aik + t*aip1k; + } + else + { /* fill-in -- insert entry & patch column */ + Real tmp; + int old_row, old_idx; + row_elt *old_e, *new_e; + + tmp = - s*aik - t*aip1k; + if ( tmp != 0.0 ) + { + row = &(A->row[j]); + old_row = scan_row->ive[s_idx2]; + old_idx = scan_idx->ive[s_idx2]; + + idx = row->len; + if ( row->len >= row->maxlen ) + { tracecatch(sprow_xpd(row,2*row->maxlen+1, + TYPE_SPMAT), + "spBKPfactor"); } + + row->len = idx + 1; + /* idx = sprow_idx(row,k); */ + new_e = &(row->elt[idx]); + new_e->val = tmp; + new_e->col = k; + + if ( old_row < 0 ) + error(E_INTERN,"spBKPfactor"); + /* old_idx = sprow_idx2(&(A->row[old_row]), + k,old_idx); */ + old_e = &(A->row[old_row].elt[old_idx]); + new_e->nxt_row = old_e->nxt_row; + new_e->nxt_idx = old_e->nxt_idx; + old_e->nxt_row = j; + old_e->nxt_idx = idx; + } + } + + /* update idx_k, idx1_k, s_idx2 etc */ + s_idx2++; + } + + /* store multipliers -- may involve fill-in (!) */ + /* idx = sprow_idx(r_piv,j); */ + idx = orig_idx->ive[s_idx]; + if ( idx >= 0 ) + { + r_piv->elt[idx].val = s; + } + else if ( s != 0.0 ) + { + int old_row, old_idx; + row_elt *new_e, *old_e; + + old_row = -1; old_idx = j; + + if ( i > 0 ) + { + tracecatch(chase_col(A,j,&old_row,&old_idx,i-1), + "spBKPfactor"); + } + /* sprow_set_val(r_piv,j,s); */ + idx = r_piv->len; + if ( r_piv->len >= r_piv->maxlen ) + { tracecatch(sprow_xpd(r_piv,2*r_piv->maxlen+1, + TYPE_SPMAT), + "spBKPfactor"); } + + r_piv->len = idx + 1; + /* idx = sprow_idx(r_piv,j); */ + /* if ( idx < 0 ) + error(E_INTERN,"spBKPfactor"); */ + new_e = &(r_piv->elt[idx]); + new_e->val = s; + new_e->col = j; + if ( old_row < 0 ) + { + new_e->nxt_row = A->start_row[j]; + new_e->nxt_idx = A->start_idx[j]; + A->start_row[j] = i; + A->start_idx[j] = idx; + } + else + { + /* old_idx = sprow_idx2(&(A->row[old_row]),j,old_idx);*/ + if ( old_idx < 0 ) + error(E_INTERN,"spBKPfactor"); + old_e = &(A->row[old_row].elt[old_idx]); + new_e->nxt_row = old_e->nxt_row; + new_e->nxt_idx = old_e->nxt_idx; + old_e->nxt_row = i; + old_e->nxt_idx = idx; + } + } + /* idx1 = sprow_idx(r1_piv,j); */ + idx1 = orig1_idx->ive[s_idx]; + if ( idx1 >= 0 ) + { + r1_piv->elt[idx1].val = t; + } + else if ( t != 0.0 ) + { + int old_row, old_idx; + row_elt *new_e, *old_e; + + old_row = -1; old_idx = j; + tracecatch(chase_col(A,j,&old_row,&old_idx,i), + "spBKPfactor"); + /* sprow_set_val(r1_piv,j,t); */ + idx1 = r1_piv->len; + if ( r1_piv->len >= r1_piv->maxlen ) + { tracecatch(sprow_xpd(r1_piv,2*r1_piv->maxlen+1, + TYPE_SPMAT), + "spBKPfactor"); } + + r1_piv->len = idx1 + 1; + /* idx1 = sprow_idx(r1_piv,j); */ + /* if ( idx < 0 ) + error(E_INTERN,"spBKPfactor"); */ + new_e = &(r1_piv->elt[idx1]); + new_e->val = t; + new_e->col = j; + if ( idx1 < 0 ) + error(E_INTERN,"spBKPfactor"); + new_e = &(r1_piv->elt[idx1]); + if ( old_row < 0 ) + { + new_e->nxt_row = A->start_row[j]; + new_e->nxt_idx = A->start_idx[j]; + A->start_row[j] = i+1; + A->start_idx[j] = idx1; + } + else + { + old_idx = sprow_idx2(&(A->row[old_row]),j,old_idx); + if ( old_idx < 0 ) + error(E_INTERN,"spBKPfactor"); + old_e = &(A->row[old_row].elt[old_idx]); + new_e->nxt_row = old_e->nxt_row; + new_e->nxt_idx = old_e->nxt_idx; + old_e->nxt_row = i+1; + old_e->nxt_idx = idx1; + } + } + } + } + } + + /* now sort the rows arrays */ + for ( i = 0; i < A->m; i++ ) + qsort(A->row[i].elt,A->row[i].len,sizeof(row_elt),(int(*)())col_cmp); + A->flag_col = A->flag_diag = FALSE; + + return A; +} + +/* spBKPsolve -- solves A.x = b where A has been factored a la BKPfactor() + -- returns x, which is created if NULL */ +VEC *spBKPsolve(A,pivot,block,b,x) +SPMAT *A; +PERM *pivot, *block; +VEC *b, *x; +{ + static VEC *tmp=VNULL; /* dummy storage needed */ + int i /* , j */, n, onebyone; + int row_num, idx; + Real a11, a12, a22, b1, b2, det, sum, *tmp_ve, tmp_diag; + SPROW *r; + row_elt *e; + + if ( ! A || ! pivot || ! block || ! b ) + error(E_NULL,"spBKPsolve"); + if ( A->m != A->n ) + error(E_SQUARE,"spBKPsolve"); + n = A->n; + if ( b->dim != n || pivot->size != n || block->size != n ) + error(E_SIZES,"spBKPsolve"); + x = v_resize(x,n); + tmp = v_resize(tmp,n); + MEM_STAT_REG(tmp,TYPE_VEC); + + tmp_ve = tmp->ve; + + if ( ! A->flag_col ) + sp_col_access(A); + + px_vec(pivot,b,tmp); + /* printf("# BKPsolve: effect of pivot: tmp =\n"); v_output(tmp); */ + + /* solve for lower triangular part */ + for ( i = 0; i < n; i++ ) + { + sum = tmp_ve[i]; + if ( block->pe[i] < i ) + { + /* for ( j = 0; j < i-1; j++ ) + sum -= A_me[j][i]*tmp_ve[j]; */ + row_num = -1; idx = i; + e = bump_col(A,i,&row_num,&idx); + while ( row_num >= 0 && row_num < i-1 ) + { + sum -= e->val*tmp_ve[row_num]; + e = bump_col(A,i,&row_num,&idx); + } + } + else + { + /* for ( j = 0; j < i; j++ ) + sum -= A_me[j][i]*tmp_ve[j]; */ + row_num = -1; idx = i; + e = bump_col(A,i,&row_num,&idx); + while ( row_num >= 0 && row_num < i ) + { + sum -= e->val*tmp_ve[row_num]; + e = bump_col(A,i,&row_num,&idx); + } + } + tmp_ve[i] = sum; + } + + /* printf("# BKPsolve: solving L part: tmp =\n"); v_output(tmp); */ + /* solve for diagonal part */ + for ( i = 0; i < n; i = onebyone ? i+1 : i+2 ) + { + onebyone = ( block->pe[i] == i ); + if ( onebyone ) + { + /* tmp_ve[i] /= A_me[i][i]; */ + tmp_diag = sp_get_val(A,i,i); + if ( tmp_diag == 0.0 ) + error(E_SING,"spBKPsolve"); + tmp_ve[i] /= tmp_diag; + } + else + { + a11 = sp_get_val(A,i,i); + a22 = sp_get_val(A,i+1,i+1); + a12 = sp_get_val(A,i,i+1); + b1 = tmp_ve[i]; + b2 = tmp_ve[i+1]; + det = a11*a22-a12*a12; /* < 0 : see BKPfactor() */ + if ( det == 0.0 ) + error(E_SING,"BKPsolve"); + det = 1/det; + tmp_ve[i] = det*(a22*b1-a12*b2); + tmp_ve[i+1] = det*(a11*b2-a12*b1); + } + } + + /* printf("# BKPsolve: solving D part: tmp =\n"); v_output(tmp); */ + /* solve for transpose of lower triangular part */ + for ( i = n-2; i >= 0; i-- ) + { + sum = tmp_ve[i]; + if ( block->pe[i] > i ) + { + /* onebyone is false */ + /* for ( j = i+2; j < n; j++ ) + sum -= A_me[i][j]*tmp_ve[j]; */ + if ( i+2 >= n ) + continue; + r = &(A->row[i]); + idx = sprow_idx(r,i+2); + idx = fixindex(idx); + e = &(r->elt[idx]); + for ( ; idx < r->len; idx++, e++ ) + sum -= e->val*tmp_ve[e->col]; + } + else /* onebyone */ + { + /* for ( j = i+1; j < n; j++ ) + sum -= A_me[i][j]*tmp_ve[j]; */ + r = &(A->row[i]); + idx = sprow_idx(r,i+1); + idx = fixindex(idx); + e = &(r->elt[idx]); + for ( ; idx < r->len; idx++, e++ ) + sum -= e->val*tmp_ve[e->col]; + } + tmp_ve[i] = sum; + } + + /* printf("# BKPsolve: solving L^T part: tmp =\n");v_output(tmp); */ + /* and do final permutation */ + x = pxinv_vec(pivot,tmp,x); + + return x; +} + + + diff --git a/meschach/spchfctr.c b/meschach/spchfctr.c new file mode 100644 index 0000000..89267e6 --- /dev/null +++ b/meschach/spchfctr.c @@ -0,0 +1,629 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Sparse Cholesky factorisation code + To be used with sparse.h, sparse.c etc + +*/ + +static char rcsid[] = "$Id: spchfctr.c,v 1.1 2001/03/01 17:19:06 rfranke Exp $"; + +#include +#include +#include "matrix.h" +#include "sparse.h" +#include "sparse2.h" + + +#ifndef MALLOCDECL +#ifndef ANSI_C +extern char *calloc(), *realloc(); +#endif +#endif + + + +/* sprow_ip -- finds the (partial) inner product of a pair of sparse rows + -- uses a "merging" approach & assumes column ordered rows + -- row indices for inner product are all < lim */ +double sprow_ip(row1, row2, lim) +SPROW *row1, *row2; +int lim; +{ + int idx1, idx2, len1, len2, tmp; + int sprow_idx(); + register row_elt *elts1, *elts2; + register Real sum; + + elts1 = row1->elt; elts2 = row2->elt; + len1 = row1->len; len2 = row2->len; + + sum = 0.0; + + if ( len1 <= 0 || len2 <= 0 ) + return 0.0; + if ( elts1->col >= lim || elts2->col >= lim ) + return 0.0; + + /* use sprow_idx() to speed up inner product where one row is + much longer than the other */ + idx1 = idx2 = 0; + if ( len1 > 2*len2 ) + { + idx1 = sprow_idx(row1,elts2->col); + idx1 = (idx1 < 0) ? -(idx1+2) : idx1; + if ( idx1 < 0 ) + error(E_UNKNOWN,"sprow_ip"); + len1 -= idx1; + } + else if ( len2 > 2*len1 ) + { + idx2 = sprow_idx(row2,elts1->col); + idx2 = (idx2 < 0) ? -(idx2+2) : idx2; + if ( idx2 < 0 ) + error(E_UNKNOWN,"sprow_ip"); + len2 -= idx2; + } + if ( len1 <= 0 || len2 <= 0 ) + return 0.0; + + elts1 = &(elts1[idx1]); elts2 = &(elts2[idx2]); + + + for ( ; ; ) /* forever do... */ + { + if ( (tmp=elts1->col-elts2->col) < 0 ) + { + len1--; elts1++; + if ( ! len1 || elts1->col >= lim ) + break; + } + else if ( tmp > 0 ) + { + len2--; elts2++; + if ( ! len2 || elts2->col >= lim ) + break; + } + else + { + sum += elts1->val * elts2->val; + len1--; elts1++; + len2--; elts2++; + if ( ! len1 || ! len2 || + elts1->col >= lim || elts2->col >= lim ) + break; + } + } + + return sum; +} + +/* sprow_sqr -- returns same as sprow_ip(row, row, lim) */ +double sprow_sqr(row, lim) +SPROW *row; +int lim; +{ + register row_elt *elts; + int idx, len; + register Real sum, tmp; + + sum = 0.0; + elts = row->elt; len = row->len; + for ( idx = 0; idx < len; idx++, elts++ ) + { + if ( elts->col >= lim ) + break; + tmp = elts->val; + sum += tmp*tmp; + } + + return sum; +} + +static int *scan_row = (int *)NULL, *scan_idx = (int *)NULL, + *col_list = (int *)NULL; +static int scan_len = 0; + +/* set_scan -- expand scan_row and scan_idx arrays + -- return new length */ +int set_scan(new_len) +int new_len; +{ + if ( new_len <= scan_len ) + return scan_len; + if ( new_len <= scan_len+5 ) + new_len += 5; + + if ( ! scan_row || ! scan_idx || ! col_list ) + { + scan_row = (int *)calloc(new_len,sizeof(int)); + scan_idx = (int *)calloc(new_len,sizeof(int)); + col_list = (int *)calloc(new_len,sizeof(int)); + } + else + { + scan_row = (int *)realloc((char *)scan_row,new_len*sizeof(int)); + scan_idx = (int *)realloc((char *)scan_idx,new_len*sizeof(int)); + col_list = (int *)realloc((char *)col_list,new_len*sizeof(int)); + } + + if ( ! scan_row || ! scan_idx || ! col_list ) + error(E_MEM,"set_scan"); + return new_len; +} + +/* spCHfactor -- sparse Cholesky factorisation + -- only the lower triangular part of A (incl. diagonal) is used */ +SPMAT *spCHfactor(A) +SPMAT *A; +{ + register int i; + int idx, k, m, minim, n, num_scan, diag_idx, tmp1; + Real pivot, tmp2; + SPROW *r_piv, *r_op; + row_elt *elt_piv, *elt_op, *old_elt; + + if ( A == SMNULL ) + error(E_NULL,"spCHfactor"); + if ( A->m != A->n ) + error(E_SQUARE,"spCHfactor"); + + /* set up access paths if not already done so */ + sp_col_access(A); + sp_diag_access(A); + + /* printf("spCHfactor() -- checkpoint 1\n"); */ + m = A->m; n = A->n; + for ( k = 0; k < m; k++ ) + { + r_piv = &(A->row[k]); + if ( r_piv->len > scan_len ) + set_scan(r_piv->len); + elt_piv = r_piv->elt; + diag_idx = sprow_idx2(r_piv,k,r_piv->diag); + if ( diag_idx < 0 ) + error(E_POSDEF,"spCHfactor"); + old_elt = &(elt_piv[diag_idx]); + for ( i = 0; i < r_piv->len; i++ ) + { + if ( elt_piv[i].col > k ) + break; + col_list[i] = elt_piv[i].col; + scan_row[i] = elt_piv[i].nxt_row; + scan_idx[i] = elt_piv[i].nxt_idx; + } + /* printf("spCHfactor() -- checkpoint 2\n"); */ + num_scan = i; /* number of actual entries in scan_row etc. */ + /* printf("num_scan = %d\n",num_scan); */ + + /* set diagonal entry of Cholesky factor */ + tmp2 = elt_piv[diag_idx].val - sprow_sqr(r_piv,k); + if ( tmp2 <= 0.0 ) + error(E_POSDEF,"spCHfactor"); + elt_piv[diag_idx].val = pivot = sqrt(tmp2); + + /* now set the k-th column of the Cholesky factors */ + /* printf("k = %d\n",k); */ + for ( ; ; ) /* forever do... */ + { + /* printf("spCHfactor() -- checkpoint 3\n"); */ + /* find next row where something (non-trivial) happens + i.e. find min(scan_row) */ + /* printf("scan_row: "); */ + minim = n; + for ( i = 0; i < num_scan; i++ ) + { + tmp1 = scan_row[i]; + /* printf("%d ",tmp1); */ + minim = ( tmp1 >= 0 && tmp1 < minim ) ? tmp1 : minim; + } + /* printf("minim = %d\n",minim); */ + /* printf("col_list: "); */ +/********************************************************************** + for ( i = 0; i < num_scan; i++ ) + printf("%d ",col_list[i]); + printf("\n"); +**********************************************************************/ + + if ( minim >= n ) + break; /* nothing more to do for this column */ + r_op = &(A->row[minim]); + elt_op = r_op->elt; + + /* set next entry in column k of Cholesky factors */ + idx = sprow_idx2(r_op,k,scan_idx[num_scan-1]); + if ( idx < 0 ) + { /* fill-in */ + sp_set_val(A,minim,k, + -sprow_ip(r_piv,r_op,k)/pivot); + /* in case a realloc() has occurred... */ + elt_op = r_op->elt; + /* now set up column access path again */ + idx = sprow_idx2(r_op,k,-(idx+2)); + tmp1 = old_elt->nxt_row; + old_elt->nxt_row = minim; + r_op->elt[idx].nxt_row = tmp1; + tmp1 = old_elt->nxt_idx; + old_elt->nxt_idx = idx; + r_op->elt[idx].nxt_idx = tmp1; + } + else + elt_op[idx].val = (elt_op[idx].val - + sprow_ip(r_piv,r_op,k))/pivot; + + /* printf("spCHfactor() -- checkpoint 4\n"); */ + + /* remember current element in column k for column chain */ + idx = sprow_idx2(r_op,k,idx); + old_elt = &(r_op->elt[idx]); + + /* update scan_row */ + /* printf("spCHfactor() -- checkpoint 5\n"); */ + /* printf("minim = %d\n",minim); */ + for ( i = 0; i < num_scan; i++ ) + { + if ( scan_row[i] != minim ) + continue; + idx = sprow_idx2(r_op,col_list[i],scan_idx[i]); + if ( idx < 0 ) + { scan_row[i] = -1; continue; } + scan_row[i] = elt_op[idx].nxt_row; + scan_idx[i] = elt_op[idx].nxt_idx; + /* printf("scan_row[%d] = %d\n",i,scan_row[i]); */ + /* printf("scan_idx[%d] = %d\n",i,scan_idx[i]); */ + } + + } + /* printf("spCHfactor() -- checkpoint 6\n"); */ + /* sp_dump(stdout,A); */ + /* printf("\n\n\n"); */ + } + + return A; +} + +/* spCHsolve -- solve L.L^T.out=b where L is a sparse matrix, + -- out, b dense vectors + -- returns out; operation may be in-situ */ +VEC *spCHsolve(L,b,out) +SPMAT *L; +VEC *b, *out; +{ + int i, j_idx, n, scan_idx, scan_row; + SPROW *row; + row_elt *elt; + Real diag_val, sum, *out_ve; + + if ( L == SMNULL || b == VNULL ) + error(E_NULL,"spCHsolve"); + if ( L->m != L->n ) + error(E_SQUARE,"spCHsolve"); + if ( b->dim != L->m ) + error(E_SIZES,"spCHsolve"); + + if ( ! L->flag_col ) + sp_col_access(L); + if ( ! L->flag_diag ) + sp_diag_access(L); + + out = v_copy(b,out); + out_ve = out->ve; + + /* forward substitution: solve L.x=b for x */ + n = L->n; + for ( i = 0; i < n; i++ ) + { + sum = out_ve[i]; + row = &(L->row[i]); + elt = row->elt; + for ( j_idx = 0; j_idx < row->len; j_idx++, elt++ ) + { + if ( elt->col >= i ) + break; + sum -= elt->val*out_ve[elt->col]; + } + if ( row->diag >= 0 ) + out_ve[i] = sum/(row->elt[row->diag].val); + else + error(E_SING,"spCHsolve"); + } + + /* backward substitution: solve L^T.out = x for out */ + for ( i = n-1; i >= 0; i-- ) + { + sum = out_ve[i]; + row = &(L->row[i]); + /* Note that row->diag >= 0 by above loop */ + elt = &(row->elt[row->diag]); + diag_val = elt->val; + + /* scan down column */ + scan_idx = elt->nxt_idx; + scan_row = elt->nxt_row; + while ( scan_row >= 0 /* && scan_idx >= 0 */ ) + { + row = &(L->row[scan_row]); + elt = &(row->elt[scan_idx]); + sum -= elt->val*out_ve[scan_row]; + scan_idx = elt->nxt_idx; + scan_row = elt->nxt_row; + } + out_ve[i] = sum/diag_val; + } + + return out; +} + +/* spICHfactor -- sparse Incomplete Cholesky factorisation + -- does a Cholesky factorisation assuming NO FILL-IN + -- as for spCHfactor(), only the lower triangular part of A is used */ +SPMAT *spICHfactor(A) +SPMAT *A; +{ + int k, m, n, nxt_row, nxt_idx, diag_idx; + Real pivot, tmp2; + SPROW *r_piv, *r_op; + row_elt *elt_piv, *elt_op; + + if ( A == SMNULL ) + error(E_NULL,"spICHfactor"); + if ( A->m != A->n ) + error(E_SQUARE,"spICHfactor"); + + /* set up access paths if not already done so */ + if ( ! A->flag_col ) + sp_col_access(A); + if ( ! A->flag_diag ) + sp_diag_access(A); + + m = A->m; n = A->n; + for ( k = 0; k < m; k++ ) + { + r_piv = &(A->row[k]); + + diag_idx = r_piv->diag; + if ( diag_idx < 0 ) + error(E_POSDEF,"spICHfactor"); + + elt_piv = r_piv->elt; + + /* set diagonal entry of Cholesky factor */ + tmp2 = elt_piv[diag_idx].val - sprow_sqr(r_piv,k); + if ( tmp2 <= 0.0 ) + error(E_POSDEF,"spICHfactor"); + elt_piv[diag_idx].val = pivot = sqrt(tmp2); + + /* find next row where something (non-trivial) happens */ + nxt_row = elt_piv[diag_idx].nxt_row; + nxt_idx = elt_piv[diag_idx].nxt_idx; + + /* now set the k-th column of the Cholesky factors */ + while ( nxt_row >= 0 && nxt_idx >= 0 ) + { + /* nxt_row and nxt_idx give next next row (& index) + of the entry to be modified */ + r_op = &(A->row[nxt_row]); + elt_op = r_op->elt; + elt_op[nxt_idx].val = (elt_op[nxt_idx].val - + sprow_ip(r_piv,r_op,k))/pivot; + + nxt_row = elt_op[nxt_idx].nxt_row; + nxt_idx = elt_op[nxt_idx].nxt_idx; + } + } + + return A; +} + + +/* spCHsymb -- symbolic sparse Cholesky factorisation + -- does NOT do any floating point arithmetic; just sets up the structure + -- only the lower triangular part of A (incl. diagonal) is used */ +SPMAT *spCHsymb(A) +SPMAT *A; +{ + register int i; + int idx, k, m, minim, n, num_scan, diag_idx, tmp1; + SPROW *r_piv, *r_op; + row_elt *elt_piv, *elt_op, *old_elt; + + if ( A == SMNULL ) + error(E_NULL,"spCHsymb"); + if ( A->m != A->n ) + error(E_SQUARE,"spCHsymb"); + + /* set up access paths if not already done so */ + if ( ! A->flag_col ) + sp_col_access(A); + if ( ! A->flag_diag ) + sp_diag_access(A); + + /* printf("spCHsymb() -- checkpoint 1\n"); */ + m = A->m; n = A->n; + for ( k = 0; k < m; k++ ) + { + r_piv = &(A->row[k]); + if ( r_piv->len > scan_len ) + set_scan(r_piv->len); + elt_piv = r_piv->elt; + diag_idx = sprow_idx2(r_piv,k,r_piv->diag); + if ( diag_idx < 0 ) + error(E_POSDEF,"spCHsymb"); + old_elt = &(elt_piv[diag_idx]); + for ( i = 0; i < r_piv->len; i++ ) + { + if ( elt_piv[i].col > k ) + break; + col_list[i] = elt_piv[i].col; + scan_row[i] = elt_piv[i].nxt_row; + scan_idx[i] = elt_piv[i].nxt_idx; + } + /* printf("spCHsymb() -- checkpoint 2\n"); */ + num_scan = i; /* number of actual entries in scan_row etc. */ + /* printf("num_scan = %d\n",num_scan); */ + + /* now set the k-th column of the Cholesky factors */ + /* printf("k = %d\n",k); */ + for ( ; ; ) /* forever do... */ + { + /* printf("spCHsymb() -- checkpoint 3\n"); */ + /* find next row where something (non-trivial) happens + i.e. find min(scan_row) */ + minim = n; + for ( i = 0; i < num_scan; i++ ) + { + tmp1 = scan_row[i]; + /* printf("%d ",tmp1); */ + minim = ( tmp1 >= 0 && tmp1 < minim ) ? tmp1 : minim; + } + + if ( minim >= n ) + break; /* nothing more to do for this column */ + r_op = &(A->row[minim]); + elt_op = r_op->elt; + + /* set next entry in column k of Cholesky factors */ + idx = sprow_idx2(r_op,k,scan_idx[num_scan-1]); + if ( idx < 0 ) + { /* fill-in */ + sp_set_val(A,minim,k,0.0); + /* in case a realloc() has occurred... */ + elt_op = r_op->elt; + /* now set up column access path again */ + idx = sprow_idx2(r_op,k,-(idx+2)); + tmp1 = old_elt->nxt_row; + old_elt->nxt_row = minim; + r_op->elt[idx].nxt_row = tmp1; + tmp1 = old_elt->nxt_idx; + old_elt->nxt_idx = idx; + r_op->elt[idx].nxt_idx = tmp1; + } + + /* printf("spCHsymb() -- checkpoint 4\n"); */ + + /* remember current element in column k for column chain */ + idx = sprow_idx2(r_op,k,idx); + old_elt = &(r_op->elt[idx]); + + /* update scan_row */ + /* printf("spCHsymb() -- checkpoint 5\n"); */ + /* printf("minim = %d\n",minim); */ + for ( i = 0; i < num_scan; i++ ) + { + if ( scan_row[i] != minim ) + continue; + idx = sprow_idx2(r_op,col_list[i],scan_idx[i]); + if ( idx < 0 ) + { scan_row[i] = -1; continue; } + scan_row[i] = elt_op[idx].nxt_row; + scan_idx[i] = elt_op[idx].nxt_idx; + /* printf("scan_row[%d] = %d\n",i,scan_row[i]); */ + /* printf("scan_idx[%d] = %d\n",i,scan_idx[i]); */ + } + + } + /* printf("spCHsymb() -- checkpoint 6\n"); */ + } + + return A; +} + +/* comp_AAT -- compute A.A^T where A is a given sparse matrix */ +SPMAT *comp_AAT(A) +SPMAT *A; +{ + SPMAT *AAT; + SPROW *r, *r2; + row_elt *elts, *elts2; + int i, idx, idx2, j, m, minim, n, num_scan, tmp1; + Real ip; + + if ( ! A ) + error(E_NULL,"comp_AAT"); + m = A->m; n = A->n; + + /* set up column access paths */ + if ( ! A->flag_col ) + sp_col_access(A); + + AAT = sp_get(m,m,10); + + for ( i = 0; i < m; i++ ) + { + /* initialisation */ + r = &(A->row[i]); + elts = r->elt; + + /* set up scan lists for this row */ + if ( r->len > scan_len ) + set_scan(r->len); + for ( j = 0; j < r->len; j++ ) + { + col_list[j] = elts[j].col; + scan_row[j] = elts[j].nxt_row; + scan_idx[j] = elts[j].nxt_idx; + } + num_scan = r->len; + + /* scan down the rows for next non-zero not + associated with a diagonal entry */ + for ( ; ; ) + { + minim = m; + for ( idx = 0; idx < num_scan; idx++ ) + { + tmp1 = scan_row[idx]; + minim = ( tmp1 >= 0 && tmp1 < minim ) ? tmp1 : minim; + } + if ( minim >= m ) + break; + r2 = &(A->row[minim]); + if ( minim > i ) + { + ip = sprow_ip(r,r2,n); + sp_set_val(AAT,minim,i,ip); + sp_set_val(AAT,i,minim,ip); + } + /* update scan entries */ + elts2 = r2->elt; + for ( idx = 0; idx < num_scan; idx++ ) + { + if ( scan_row[idx] != minim || scan_idx[idx] < 0 ) + continue; + idx2 = scan_idx[idx]; + scan_row[idx] = elts2[idx2].nxt_row; + scan_idx[idx] = elts2[idx2].nxt_idx; + } + } + + /* set the diagonal entry */ + sp_set_val(AAT,i,i,sprow_sqr(r,n)); + } + + return AAT; +} + diff --git a/meschach/splufctr.c b/meschach/splufctr.c new file mode 100644 index 0000000..1cc6f3e --- /dev/null +++ b/meschach/splufctr.c @@ -0,0 +1,410 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Sparse LU factorisation -- NO pivoting + See also: sparse.[ch] etc for details about sparse matrices +*/ + +#include +#include +#include "sparse2.h" + + + +/* Macro for speedup */ +/* #define sprow_idx2(r,c,hint) \ + ( ( (hint) >= 0 && (r)->elt[hint].col == (c)) ? hint : sprow_idx((r),(c)) ) */ + + +/* spLUfactor -- sparse LU factorisation with pivoting + -- uses partial pivoting and Markowitz criterion + |a[p][k]| >= alpha * max_i |a[i][k]| + -- creates fill-in as needed + -- in situ factorisation */ +SPMAT *spLUfactor(A,px,alpha) +SPMAT *A; +PERM *px; +double alpha; +{ + int i, best_i, k, idx, len, best_len, m, n; + SPROW *r, *r_piv, tmp_row; + static SPROW *merge = (SPROW *)NULL; + Real max_val, tmp; + static VEC *col_vals=VNULL; + + if ( ! A || ! px ) + error(E_NULL,"spLUfctr"); + if ( alpha <= 0.0 || alpha > 1.0 ) + error(E_RANGE,"alpha in spLUfctr"); + if ( px->size <= A->m ) + px = px_resize(px,A->m); + px_ident(px); + col_vals = v_resize(col_vals,A->m); + MEM_STAT_REG(col_vals,TYPE_VEC); + + m = A->m; n = A->n; + if ( ! A->flag_col ) + sp_col_access(A); + if ( ! A->flag_diag ) + sp_diag_access(A); + A->flag_col = A->flag_diag = FALSE; + if ( ! merge ) { + merge = sprow_get(20); + MEM_STAT_REG(merge,TYPE_SPROW); + } + + for ( k = 0; k < n; k++ ) + { + /* find pivot row/element for partial pivoting */ + + /* get first row with a non-zero entry in the k-th column */ + max_val = 0.0; + for ( i = k; i < m; i++ ) + { + r = &(A->row[i]); + idx = sprow_idx(r,k); + if ( idx < 0 ) + tmp = 0.0; + else + tmp = r->elt[idx].val; + if ( fabs(tmp) > max_val ) + max_val = fabs(tmp); + col_vals->ve[i] = tmp; + } + + if ( max_val == 0.0 ) + continue; + + best_len = n+1; /* only if no possibilities */ + best_i = -1; + for ( i = k; i < m; i++ ) + { + tmp = fabs(col_vals->ve[i]); + if ( tmp == 0.0 ) + continue; + if ( tmp >= alpha*max_val ) + { + r = &(A->row[i]); + idx = sprow_idx(r,k); + len = (r->len) - idx; + if ( len < best_len ) + { + best_len = len; + best_i = i; + } + } + } + + /* swap row #best_i with row #k */ + MEM_COPY(&(A->row[best_i]),&tmp_row,sizeof(SPROW)); + MEM_COPY(&(A->row[k]),&(A->row[best_i]),sizeof(SPROW)); + MEM_COPY(&tmp_row,&(A->row[k]),sizeof(SPROW)); + /* swap col_vals entries */ + tmp = col_vals->ve[best_i]; + col_vals->ve[best_i] = col_vals->ve[k]; + col_vals->ve[k] = tmp; + px_transp(px,k,best_i); + + r_piv = &(A->row[k]); + for ( i = k+1; i < n; i++ ) + { + /* compute and set multiplier */ + tmp = col_vals->ve[i]/col_vals->ve[k]; + if ( tmp != 0.0 ) + sp_set_val(A,i,k,tmp); + else + continue; + + /* perform row operations */ + merge->len = 0; + r = &(A->row[i]); + sprow_mltadd(r,r_piv,-tmp,k+1,merge,TYPE_SPROW); + idx = sprow_idx(r,k+1); + if ( idx < 0 ) + idx = -(idx+2); + /* see if r needs expanding */ + if ( r->maxlen < idx + merge->len ) + sprow_xpd(r,idx+merge->len,TYPE_SPMAT); + r->len = idx+merge->len; + MEM_COPY((char *)(merge->elt),(char *)&(r->elt[idx]), + merge->len*sizeof(row_elt)); + } + } + + return A; +} + +/* spLUsolve -- solve A.x = b using factored matrix A from spLUfactor() + -- returns x + -- may not be in-situ */ +VEC *spLUsolve(A,pivot,b,x) +SPMAT *A; +PERM *pivot; +VEC *b, *x; +{ + int i, idx, len, lim; + Real sum, *x_ve; + SPROW *r; + row_elt *elt; + + if ( ! A || ! b ) + error(E_NULL,"spLUsolve"); + if ( (pivot != PNULL && A->m != pivot->size) || A->m != b->dim ) + error(E_SIZES,"spLUsolve"); + if ( ! x || x->dim != A->n ) + x = v_resize(x,A->n); + + if ( pivot != PNULL ) + x = px_vec(pivot,b,x); + else + x = v_copy(b,x); + + x_ve = x->ve; + lim = min(A->m,A->n); + for ( i = 0; i < lim; i++ ) + { + sum = x_ve[i]; + r = &(A->row[i]); + len = r->len; + elt = r->elt; + for ( idx = 0; idx < len && elt->col < i; idx++, elt++ ) + sum -= elt->val*x_ve[elt->col]; + x_ve[i] = sum; + } + + for ( i = lim-1; i >= 0; i-- ) + { + sum = x_ve[i]; + r = &(A->row[i]); + len = r->len; + elt = &(r->elt[len-1]); + for ( idx = len-1; idx >= 0 && elt->col > i; idx--, elt-- ) + sum -= elt->val*x_ve[elt->col]; + if ( idx < 0 || elt->col != i || elt->val == 0.0 ) + error(E_SING,"spLUsolve"); + x_ve[i] = sum/elt->val; + } + + return x; +} + +/* spLUTsolve -- solve A.x = b using factored matrix A from spLUfactor() + -- returns x + -- may not be in-situ */ +VEC *spLUTsolve(A,pivot,b,x) +SPMAT *A; +PERM *pivot; +VEC *b, *x; +{ + int i, idx, lim, rownum; + Real sum, *tmp_ve; + /* SPROW *r; */ + row_elt *elt; + static VEC *tmp=VNULL; + + if ( ! A || ! b ) + error(E_NULL,"spLUTsolve"); + if ( (pivot != PNULL && A->m != pivot->size) || A->m != b->dim ) + error(E_SIZES,"spLUTsolve"); + tmp = v_copy(b,tmp); + MEM_STAT_REG(tmp,TYPE_VEC); + + if ( ! A->flag_col ) + sp_col_access(A); + if ( ! A->flag_diag ) + sp_diag_access(A); + + lim = min(A->m,A->n); + tmp_ve = tmp->ve; + /* solve U^T.tmp = b */ + for ( i = 0; i < lim; i++ ) + { + sum = tmp_ve[i]; + rownum = A->start_row[i]; + idx = A->start_idx[i]; + if ( rownum < 0 || idx < 0 ) + error(E_SING,"spLUTsolve"); + while ( rownum < i && rownum >= 0 && idx >= 0 ) + { + elt = &(A->row[rownum].elt[idx]); + sum -= elt->val*tmp_ve[rownum]; + rownum = elt->nxt_row; + idx = elt->nxt_idx; + } + if ( rownum != i ) + error(E_SING,"spLUTsolve"); + elt = &(A->row[rownum].elt[idx]); + if ( elt->val == 0.0 ) + error(E_SING,"spLUTsolve"); + tmp_ve[i] = sum/elt->val; + } + + /* now solve L^T.tmp = (old) tmp */ + for ( i = lim-1; i >= 0; i-- ) + { + sum = tmp_ve[i]; + rownum = i; + idx = A->row[rownum].diag; + if ( idx < 0 ) + error(E_NULL,"spLUTsolve"); + elt = &(A->row[rownum].elt[idx]); + rownum = elt->nxt_row; + idx = elt->nxt_idx; + while ( rownum < lim && rownum >= 0 && idx >= 0 ) + { + elt = &(A->row[rownum].elt[idx]); + sum -= elt->val*tmp_ve[rownum]; + rownum = elt->nxt_row; + idx = elt->nxt_idx; + } + tmp_ve[i] = sum; + } + + if ( pivot != PNULL ) + x = pxinv_vec(pivot,tmp,x); + else + x = v_copy(tmp,x); + + return x; +} + +/* spILUfactor -- sparse modified incomplete LU factorisation with + no pivoting + -- all pivot entries are ensured to be >= alpha in magnitude + -- setting alpha = 0 gives incomplete LU factorisation + -- no fill-in is generated + -- in situ factorisation */ +SPMAT *spILUfactor(A,alpha) +SPMAT *A; +double alpha; +{ + int i, k, idx, idx_piv, m, n, old_idx, old_idx_piv; + SPROW *r, *r_piv; + Real piv_val, tmp; + + /* printf("spILUfactor: entered\n"); */ + if ( ! A ) + error(E_NULL,"spILUfactor"); + if ( alpha < 0.0 ) + error(E_RANGE,"[alpha] in spILUfactor"); + + m = A->m; n = A->n; + sp_diag_access(A); + sp_col_access(A); + + for ( k = 0; k < n; k++ ) + { + /* printf("spILUfactor(l.%d): checkpoint A: k = %d\n",__LINE__,k); */ + /* printf("spILUfactor(l.%d): A =\n", __LINE__); */ + /* sp_output(A); */ + r_piv = &(A->row[k]); + idx_piv = r_piv->diag; + if ( idx_piv < 0 ) + { + sprow_set_val(r_piv,k,alpha); + idx_piv = sprow_idx(r_piv,k); + } + /* printf("spILUfactor: checkpoint B\n"); */ + if ( idx_piv < 0 ) + error(E_BOUNDS,"spILUfactor"); + old_idx_piv = idx_piv; + piv_val = r_piv->elt[idx_piv].val; + /* printf("spILUfactor: checkpoint C\n"); */ + if ( fabs(piv_val) < alpha ) + piv_val = ( piv_val < 0.0 ) ? -alpha : alpha; + if ( piv_val == 0.0 ) /* alpha == 0.0 too! */ + error(E_SING,"spILUfactor"); + + /* go to next row with a non-zero in this column */ + i = r_piv->elt[idx_piv].nxt_row; + old_idx = idx = r_piv->elt[idx_piv].nxt_idx; + while ( i >= k ) + { + /* printf("spILUfactor: checkpoint D: i = %d\n",i); */ + /* perform row operations */ + r = &(A->row[i]); + /* idx = sprow_idx(r,k); */ + /* printf("spLUfactor(l.%d) i = %d, idx = %d\n", + __LINE__, i, idx); */ + if ( idx < 0 ) + { + idx = r->elt[old_idx].nxt_idx; + i = r->elt[old_idx].nxt_row; + continue; + } + /* printf("spILUfactor: checkpoint E\n"); */ + /* compute and set multiplier */ + r->elt[idx].val = tmp = r->elt[idx].val/piv_val; + /* printf("spILUfactor: piv_val = %g, multiplier = %g\n", + piv_val, tmp); */ + /* printf("spLUfactor(l.%d) multiplier = %g\n", __LINE__, tmp); */ + if ( tmp == 0.0 ) + { + idx = r->elt[old_idx].nxt_idx; + i = r->elt[old_idx].nxt_row; + continue; + } + /* idx = sprow_idx(r,k+1); */ + /* if ( idx < 0 ) + idx = -(idx+2); */ + idx_piv++; idx++; /* now look beyond the multiplier entry */ + /* printf("spILUfactor: checkpoint F: idx = %d, idx_piv = %d\n", + idx, idx_piv); */ + while ( idx_piv < r_piv->len && idx < r->len ) + { + /* printf("spILUfactor: checkpoint G: idx = %d, idx_piv = %d\n", + idx, idx_piv); */ + if ( r_piv->elt[idx_piv].col < r->elt[idx].col ) + idx_piv++; + else if ( r_piv->elt[idx_piv].col > r->elt[idx].col ) + idx++; + else /* column numbers match */ + { + /* printf("spILUfactor(l.%d) subtract %g times the ", + __LINE__, tmp); */ + /* printf("(%d,%d) entry to the (%d,%d) entry\n", + k, r_piv->elt[idx_piv].col, + i, r->elt[idx].col); */ + r->elt[idx].val -= tmp*r_piv->elt[idx_piv].val; + idx++; idx_piv++; + } + } + + /* bump to next row with a non-zero in column k */ + /* printf("spILUfactor(l.%d) column = %d, row[%d] =\n", + __LINE__, r->elt[old_idx].col, i); */ + /* sprow_foutput(stdout,r); */ + i = r->elt[old_idx].nxt_row; + old_idx = idx = r->elt[old_idx].nxt_idx; + /* printf("spILUfactor(l.%d) i = %d, idx = %d\n", __LINE__, i, idx); */ + /* and restore idx_piv to index of pivot entry */ + idx_piv = old_idx_piv; + } + } + /* printf("spILUfactor: exiting\n"); */ + return A; +} diff --git a/meschach/sprow.c b/meschach/sprow.c new file mode 100644 index 0000000..31bf8ce --- /dev/null +++ b/meschach/sprow.c @@ -0,0 +1,726 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + +/* + Sparse rows package + See also: sparse.h, matrix.h + */ + +#include +#include +#include +#include "sparse.h" + + +static char rcsid[] = "$Id: sprow.c,v 1.1 2001/03/01 17:19:08 rfranke Exp $"; + +#define MINROWLEN 10 + + +/* sprow_dump - prints relevant information about the sparse row r */ + +void sprow_dump(fp,r) +FILE *fp; +SPROW *r; +{ + int j_idx; + row_elt *elts; + + fprintf(fp,"SparseRow dump:\n"); + if ( ! r ) + { fprintf(fp,"*** NULL row ***\n"); return; } + + fprintf(fp,"row: len = %d, maxlen = %d, diag idx = %d\n", + r->len,r->maxlen,r->diag); + fprintf(fp,"element list @ 0x%lx\n",(long)(r->elt)); + if ( ! r->elt ) + { + fprintf(fp,"*** NULL element list ***\n"); + return; + } + elts = r->elt; + for ( j_idx = 0; j_idx < r->len; j_idx++, elts++ ) +#ifdef SPARSE_COL_ACCESS + fprintf(fp,"Col: %d, Val: %g, nxt_row = %d, nxt_idx = %d\n", + elts->col,elts->val,elts->nxt_row,elts->nxt_idx); +#else + fprintf(fp,"Col: %d, Val: %g\n", + elts->col,elts->val); +#endif + fprintf(fp,"\n"); +} + + +/* sprow_idx -- get index into row for a given column in a given row + -- return -1 on error + -- return -(idx+2) where idx is index to insertion point */ +int sprow_idx(r,col) +SPROW *r; +int col; +{ + register int lo, hi, mid; + int tmp; + register row_elt *r_elt; + + /******************************************* + if ( r == (SPROW *)NULL ) + return -1; + if ( col < 0 ) + return -1; + *******************************************/ + + r_elt = r->elt; + if ( r->len <= 0 ) + return -2; + + /* try the hint */ + /* if ( hint >= 0 && hint < r->len && r_elt[hint].col == col ) + return hint; */ + + /* otherwise use binary search... */ + /* code from K&R Ch. 6, p. 125 */ + lo = 0; hi = r->len - 1; mid = lo; + while ( lo <= hi ) + { + mid = (hi + lo)/2; + if ( (tmp=r_elt[mid].col-col) > 0 ) + hi = mid-1; + else if ( tmp < 0 ) + lo = mid+1; + else /* tmp == 0 */ + return mid; + } + tmp = r_elt[mid].col - col; + + if ( tmp > 0 ) + return -(mid+2); /* insert at mid */ + else /* tmp < 0 */ + return -(mid+3); /* insert at mid+1 */ +} + + +/* sprow_get -- gets, initialises and returns a SPROW structure + -- max. length is maxlen */ +SPROW *sprow_get(maxlen) +int maxlen; +{ + SPROW *r; + + if ( maxlen < 0 ) + error(E_NEG,"sprow_get"); + + r = NEW(SPROW); + if ( ! r ) + error(E_MEM,"sprow_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPROW,0,sizeof(SPROW)); + mem_numvar(TYPE_SPROW,1); + } + r->elt = NEW_A(maxlen,row_elt); + if ( ! r->elt ) + error(E_MEM,"sprow_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_SPROW,0,maxlen*sizeof(row_elt)); + } + r->len = 0; + r->maxlen = maxlen; + r->diag = -1; + + return r; +} + + +/* sprow_xpd -- expand row by means of realloc() + -- type must be TYPE_SPMAT if r is a row of a SPMAT structure, + otherwise it must be TYPE_SPROW + -- returns r */ +SPROW *sprow_xpd(r,n,type) +SPROW *r; +int n,type; +{ + int newlen; + + if ( ! r ) { + r = NEW(SPROW); + if (! r ) + error(E_MEM,"sprow_xpd"); + else if ( mem_info_is_on()) { + if (type != TYPE_SPMAT && type != TYPE_SPROW) + warning(WARN_WRONG_TYPE,"sprow_xpd"); + mem_bytes(type,0,sizeof(SPROW)); + if (type == TYPE_SPROW) + mem_numvar(type,1); + } + } + + if ( ! r->elt ) + { + r->elt = NEW_A((unsigned)n,row_elt); + if ( ! r->elt ) + error(E_MEM,"sprow_xpd"); + else if (mem_info_is_on()) { + mem_bytes(type,0,n*sizeof(row_elt)); + } + r->len = 0; + r->maxlen = n; + return r; + } + if ( n <= r->len ) + newlen = max(2*r->len + 1,MINROWLEN); + else + newlen = n; + if ( newlen <= r->maxlen ) + { + MEM_ZERO((char *)(&(r->elt[r->len])), + (newlen-r->len)*sizeof(row_elt)); + r->len = newlen; + } + else + { + if (mem_info_is_on()) { + mem_bytes(type,r->maxlen*sizeof(row_elt), + newlen*sizeof(row_elt)); + } + r->elt = RENEW(r->elt,newlen,row_elt); + if ( ! r->elt ) + error(E_MEM,"sprow_xpd"); + r->maxlen = newlen; + r->len = newlen; + } + + return r; +} + +/* sprow_resize -- resize a SPROW variable by means of realloc() + -- n is a new size + -- returns r */ +SPROW *sprow_resize(r,n,type) +SPROW *r; +int n,type; +{ + if (n < 0) + error(E_NEG,"sprow_resize"); + + if ( ! r ) + return sprow_get(n); + + if (n == r->len) + return r; + + if ( ! r->elt ) + { + r->elt = NEW_A((unsigned)n,row_elt); + if ( ! r->elt ) + error(E_MEM,"sprow_resize"); + else if (mem_info_is_on()) { + mem_bytes(type,0,n*sizeof(row_elt)); + } + r->maxlen = r->len = n; + return r; + } + + if ( n <= r->maxlen ) + r->len = n; + else + { + if (mem_info_is_on()) { + mem_bytes(type,r->maxlen*sizeof(row_elt), + n*sizeof(row_elt)); + } + r->elt = RENEW(r->elt,n,row_elt); + if ( ! r->elt ) + error(E_MEM,"sprow_resize"); + r->maxlen = r->len = n; + } + + return r; +} + + +/* release a row of a matrix */ +int sprow_free(r) +SPROW *r; +{ + if ( ! r ) + return -1; + + if (mem_info_is_on()) { + mem_bytes(TYPE_SPROW,sizeof(SPROW),0); + mem_numvar(TYPE_SPROW,-1); + } + + if ( r->elt ) + { + if (mem_info_is_on()) { + mem_bytes(TYPE_SPROW,r->maxlen*sizeof(row_elt),0); + } + free((char *)r->elt); + } + free((char *)r); + return 0; +} + + +/* sprow_merge -- merges r1 and r2 into r_out + -- cannot be done in-situ + -- type must be SPMAT or SPROW depending on + whether r_out is a row of a SPMAT structure + or a SPROW variable + -- returns r_out */ +SPROW *sprow_merge(r1,r2,r_out,type) +SPROW *r1, *r2, *r_out; +int type; +{ + int idx1, idx2, idx_out, len1, len2, len_out; + row_elt *elt1, *elt2, *elt_out; + + if ( ! r1 || ! r2 ) + error(E_NULL,"sprow_merge"); + if ( ! r_out ) + r_out = sprow_get(MINROWLEN); + if ( r1 == r_out || r2 == r_out ) + error(E_INSITU,"sprow_merge"); + + /* Initialise */ + len1 = r1->len; len2 = r2->len; len_out = r_out->maxlen; + idx1 = idx2 = idx_out = 0; + elt1 = r1->elt; elt2 = r2->elt; elt_out = r_out->elt; + + while ( idx1 < len1 || idx2 < len2 ) + { + if ( idx_out >= len_out ) + { /* r_out is too small */ + r_out->len = idx_out; + r_out = sprow_xpd(r_out,0,type); + len_out = r_out->len; + elt_out = &(r_out->elt[idx_out]); + } + if ( idx2 >= len2 || (idx1 < len1 && elt1->col <= elt2->col) ) + { + elt_out->col = elt1->col; + elt_out->val = elt1->val; + if ( elt1->col == elt2->col && idx2 < len2 ) + { elt2++; idx2++; } + elt1++; idx1++; + } + else + { + elt_out->col = elt2->col; + elt_out->val = elt2->val; + elt2++; idx2++; + } + elt_out++; idx_out++; + } + r_out->len = idx_out; + + return r_out; +} + +/* sprow_copy -- copies r1 and r2 into r_out + -- cannot be done in-situ + -- type must be SPMAT or SPROW depending on + whether r_out is a row of a SPMAT structure + or a SPROW variable + -- returns r_out */ +SPROW *sprow_copy(r1,r2,r_out,type) +SPROW *r1, *r2, *r_out; +int type; +{ + int idx1, idx2, idx_out, len1, len2, len_out; + row_elt *elt1, *elt2, *elt_out; + + if ( ! r1 || ! r2 ) + error(E_NULL,"sprow_copy"); + if ( ! r_out ) + r_out = sprow_get(MINROWLEN); + if ( r1 == r_out || r2 == r_out ) + error(E_INSITU,"sprow_copy"); + + /* Initialise */ + len1 = r1->len; len2 = r2->len; len_out = r_out->maxlen; + idx1 = idx2 = idx_out = 0; + elt1 = r1->elt; elt2 = r2->elt; elt_out = r_out->elt; + + while ( idx1 < len1 || idx2 < len2 ) + { + while ( idx_out >= len_out ) + { /* r_out is too small */ + r_out->len = idx_out; + r_out = sprow_xpd(r_out,0,type); + len_out = r_out->maxlen; + elt_out = &(r_out->elt[idx_out]); + } + if ( idx2 >= len2 || (idx1 < len1 && elt1->col <= elt2->col) ) + { + elt_out->col = elt1->col; + elt_out->val = elt1->val; + if ( elt1->col == elt2->col && idx2 < len2 ) + { elt2++; idx2++; } + elt1++; idx1++; + } + else + { + elt_out->col = elt2->col; + elt_out->val = 0.0; + elt2++; idx2++; + } + elt_out++; idx_out++; + } + r_out->len = idx_out; + + return r_out; +} + +/* sprow_mltadd -- sets r_out <- r1 + alpha.r2 + -- cannot be in situ + -- only for columns j0, j0+1, ... + -- type must be SPMAT or SPROW depending on + whether r_out is a row of a SPMAT structure + or a SPROW variable + -- returns r_out */ +SPROW *sprow_mltadd(r1,r2,alpha,j0,r_out,type) +SPROW *r1, *r2, *r_out; +double alpha; +int j0, type; +{ + int idx1, idx2, idx_out, len1, len2, len_out; + row_elt *elt1, *elt2, *elt_out; + + if ( ! r1 || ! r2 ) + error(E_NULL,"sprow_mltadd"); + if ( r1 == r_out || r2 == r_out ) + error(E_INSITU,"sprow_mltadd"); + if ( j0 < 0 ) + error(E_BOUNDS,"sprow_mltadd"); + if ( ! r_out ) + r_out = sprow_get(MINROWLEN); + + /* Initialise */ + len1 = r1->len; len2 = r2->len; len_out = r_out->maxlen; + /* idx1 = idx2 = idx_out = 0; */ + idx1 = sprow_idx(r1,j0); + idx2 = sprow_idx(r2,j0); + idx_out = sprow_idx(r_out,j0); + idx1 = (idx1 < 0) ? -(idx1+2) : idx1; + idx2 = (idx2 < 0) ? -(idx2+2) : idx2; + idx_out = (idx_out < 0) ? -(idx_out+2) : idx_out; + elt1 = &(r1->elt[idx1]); + elt2 = &(r2->elt[idx2]); + elt_out = &(r_out->elt[idx_out]); + + while ( idx1 < len1 || idx2 < len2 ) + { + if ( idx_out >= len_out ) + { /* r_out is too small */ + r_out->len = idx_out; + r_out = sprow_xpd(r_out,0,type); + len_out = r_out->maxlen; + elt_out = &(r_out->elt[idx_out]); + } + if ( idx2 >= len2 || (idx1 < len1 && elt1->col <= elt2->col) ) + { + elt_out->col = elt1->col; + elt_out->val = elt1->val; + if ( idx2 < len2 && elt1->col == elt2->col ) + { + elt_out->val += alpha*elt2->val; + elt2++; idx2++; + } + elt1++; idx1++; + } + else + { + elt_out->col = elt2->col; + elt_out->val = alpha*elt2->val; + elt2++; idx2++; + } + elt_out++; idx_out++; + } + r_out->len = idx_out; + + return r_out; +} + +/* sprow_add -- sets r_out <- r1 + r2 + -- cannot be in situ + -- only for columns j0, j0+1, ... + -- type must be SPMAT or SPROW depending on + whether r_out is a row of a SPMAT structure + or a SPROW variable + -- returns r_out */ +SPROW *sprow_add(r1,r2,j0,r_out,type) +SPROW *r1, *r2, *r_out; +int j0, type; +{ + int idx1, idx2, idx_out, len1, len2, len_out; + row_elt *elt1, *elt2, *elt_out; + + if ( ! r1 || ! r2 ) + error(E_NULL,"sprow_add"); + if ( r1 == r_out || r2 == r_out ) + error(E_INSITU,"sprow_add"); + if ( j0 < 0 ) + error(E_BOUNDS,"sprow_add"); + if ( ! r_out ) + r_out = sprow_get(MINROWLEN); + + /* Initialise */ + len1 = r1->len; len2 = r2->len; len_out = r_out->maxlen; + /* idx1 = idx2 = idx_out = 0; */ + idx1 = sprow_idx(r1,j0); + idx2 = sprow_idx(r2,j0); + idx_out = sprow_idx(r_out,j0); + idx1 = (idx1 < 0) ? -(idx1+2) : idx1; + idx2 = (idx2 < 0) ? -(idx2+2) : idx2; + idx_out = (idx_out < 0) ? -(idx_out+2) : idx_out; + elt1 = &(r1->elt[idx1]); + elt2 = &(r2->elt[idx2]); + elt_out = &(r_out->elt[idx_out]); + + while ( idx1 < len1 || idx2 < len2 ) + { + if ( idx_out >= len_out ) + { /* r_out is too small */ + r_out->len = idx_out; + r_out = sprow_xpd(r_out,0,type); + len_out = r_out->maxlen; + elt_out = &(r_out->elt[idx_out]); + } + if ( idx2 >= len2 || (idx1 < len1 && elt1->col <= elt2->col) ) + { + elt_out->col = elt1->col; + elt_out->val = elt1->val; + if ( idx2 < len2 && elt1->col == elt2->col ) + { + elt_out->val += elt2->val; + elt2++; idx2++; + } + elt1++; idx1++; + } + else + { + elt_out->col = elt2->col; + elt_out->val = elt2->val; + elt2++; idx2++; + } + elt_out++; idx_out++; + } + r_out->len = idx_out; + + return r_out; +} + +/* sprow_sub -- sets r_out <- r1 - r2 + -- cannot be in situ + -- only for columns j0, j0+1, ... + -- type must be SPMAT or SPROW depending on + whether r_out is a row of a SPMAT structure + or a SPROW variable + -- returns r_out */ +SPROW *sprow_sub(r1,r2,j0,r_out,type) +SPROW *r1, *r2, *r_out; +int j0, type; +{ + int idx1, idx2, idx_out, len1, len2, len_out; + row_elt *elt1, *elt2, *elt_out; + + if ( ! r1 || ! r2 ) + error(E_NULL,"sprow_sub"); + if ( r1 == r_out || r2 == r_out ) + error(E_INSITU,"sprow_sub"); + if ( j0 < 0 ) + error(E_BOUNDS,"sprow_sub"); + if ( ! r_out ) + r_out = sprow_get(MINROWLEN); + + /* Initialise */ + len1 = r1->len; len2 = r2->len; len_out = r_out->maxlen; + /* idx1 = idx2 = idx_out = 0; */ + idx1 = sprow_idx(r1,j0); + idx2 = sprow_idx(r2,j0); + idx_out = sprow_idx(r_out,j0); + idx1 = (idx1 < 0) ? -(idx1+2) : idx1; + idx2 = (idx2 < 0) ? -(idx2+2) : idx2; + idx_out = (idx_out < 0) ? -(idx_out+2) : idx_out; + elt1 = &(r1->elt[idx1]); + elt2 = &(r2->elt[idx2]); + elt_out = &(r_out->elt[idx_out]); + + while ( idx1 < len1 || idx2 < len2 ) + { + if ( idx_out >= len_out ) + { /* r_out is too small */ + r_out->len = idx_out; + r_out = sprow_xpd(r_out,0,type); + len_out = r_out->maxlen; + elt_out = &(r_out->elt[idx_out]); + } + if ( idx2 >= len2 || (idx1 < len1 && elt1->col <= elt2->col) ) + { + elt_out->col = elt1->col; + elt_out->val = elt1->val; + if ( idx2 < len2 && elt1->col == elt2->col ) + { + elt_out->val -= elt2->val; + elt2++; idx2++; + } + elt1++; idx1++; + } + else + { + elt_out->col = elt2->col; + elt_out->val = -elt2->val; + elt2++; idx2++; + } + elt_out++; idx_out++; + } + r_out->len = idx_out; + + return r_out; +} + + +/* sprow_smlt -- sets r_out <- alpha*r1 + -- can be in situ + -- only for columns j0, j0+1, ... + -- returns r_out */ +SPROW *sprow_smlt(r1,alpha,j0,r_out,type) +SPROW *r1, *r_out; +double alpha; +int j0, type; +{ + int idx1, idx_out, len1; + row_elt *elt1, *elt_out; + + if ( ! r1 ) + error(E_NULL,"sprow_smlt"); + if ( j0 < 0 ) + error(E_BOUNDS,"sprow_smlt"); + if ( ! r_out ) + r_out = sprow_get(MINROWLEN); + + /* Initialise */ + len1 = r1->len; + idx1 = sprow_idx(r1,j0); + idx_out = sprow_idx(r_out,j0); + idx1 = (idx1 < 0) ? -(idx1+2) : idx1; + idx_out = (idx_out < 0) ? -(idx_out+2) : idx_out; + elt1 = &(r1->elt[idx1]); + + r_out = sprow_resize(r_out,idx_out+len1-idx1,type); + elt_out = &(r_out->elt[idx_out]); + + for ( ; idx1 < len1; elt1++,elt_out++,idx1++,idx_out++ ) + { + elt_out->col = elt1->col; + elt_out->val = alpha*elt1->val; + } + + r_out->len = idx_out; + + return r_out; +} + + +/* sprow_foutput -- print a representation of r on stream fp */ +void sprow_foutput(fp,r) +FILE *fp; +SPROW *r; +{ + int i, len; + row_elt *e; + + if ( ! r ) + { + fprintf(fp,"SparseRow: **** NULL ****\n"); + return; + } + len = r->len; + fprintf(fp,"SparseRow: length: %d\n",len); + for ( i = 0, e = r->elt; i < len; i++, e++ ) +#ifdef SPARSE_COL_ACCESS + fprintf(fp,"Column %d: %g, next row: %d, next index %d\n", + e->col, e->val, e->nxt_row, e->nxt_idx); +#else + fprintf(fp,"Column %d: %g\n", + e->col, e->val); +#endif +} + + +/* sprow_set_val -- sets the j-th column entry of the sparse row r + -- Note: destroys the usual column & row access paths */ +double sprow_set_val(r,j,val) +SPROW *r; +int j; +double val; +{ + int idx, idx2, new_len; + + if ( ! r ) + error(E_NULL,"sprow_set_val"); + + idx = sprow_idx(r,j); + if ( idx >= 0 ) + { r->elt[idx].val = val; return val; } + /* else */ if ( idx < -1 ) + { + /* shift & insert new value */ + idx = -(idx+2); /* this is the intended insertion index */ + if ( r->len >= r->maxlen ) + { + r->len = r->maxlen; + new_len = max(2*r->maxlen+1,5); + if (mem_info_is_on()) { + mem_bytes(TYPE_SPROW,r->maxlen*sizeof(row_elt), + new_len*sizeof(row_elt)); + } + + r->elt = RENEW(r->elt,new_len,row_elt); + if ( ! r->elt ) /* can't allocate */ + error(E_MEM,"sprow_set_val"); + r->maxlen = 2*r->maxlen+1; + } + for ( idx2 = r->len-1; idx2 >= idx; idx2-- ) + MEM_COPY((char *)(&(r->elt[idx2])), + (char *)(&(r->elt[idx2+1])),sizeof(row_elt)); + /************************************************************ + if ( idx < r->len ) + MEM_COPY((char *)(&(r->elt[idx])),(char *)(&(r->elt[idx+1])), + (r->len-idx)*sizeof(row_elt)); + ************************************************************/ + r->len++; + r->elt[idx].col = j; +#ifdef SPARSE_COL_ACCESS + r->elt[idx].nxt_row = -1; + r->elt[idx].nxt_idx = -1; +#endif + return r->elt[idx].val = val; + } + /* else -- idx == -1, error in index/matrix! */ + return 0.0; +} + + diff --git a/meschach/spswap.c b/meschach/spswap.c new file mode 100644 index 0000000..6440174 --- /dev/null +++ b/meschach/spswap.c @@ -0,0 +1,304 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Sparse matrix swap and permutation routines + Modified Mon 09th Nov 1992, 08:50:54 PM + to use Karen George's suggestion to use unordered rows +*/ + +static char rcsid[] = "$Id: spswap.c,v 1.1 2001/03/01 17:19:09 rfranke Exp $"; + +#include +#include +#include "matrix.h" +#include "sparse.h" +#include "sparse2.h" + + +#define btos(x) ((x) ? "TRUE" : "FALSE") + +/* scan_to -- updates scan (int) vectors to point to the last row in each + column with row # <= max_row, if any */ +void scan_to(A, scan_row, scan_idx, col_list, max_row) +SPMAT *A; +IVEC *scan_row, *scan_idx, *col_list; +int max_row; +{ + int col, idx, j_idx, row_num; + SPROW *r; + row_elt *e; + + if ( ! A || ! scan_row || ! scan_idx || ! col_list ) + error(E_NULL,"scan_to"); + if ( scan_row->dim != scan_idx->dim || scan_idx->dim != col_list->dim ) + error(E_SIZES,"scan_to"); + + if ( max_row < 0 ) + return; + + if ( ! A->flag_col ) + sp_col_access(A); + + for ( j_idx = 0; j_idx < scan_row->dim; j_idx++ ) + { + row_num = scan_row->ive[j_idx]; + idx = scan_idx->ive[j_idx]; + col = col_list->ive[j_idx]; + + if ( col < 0 || col >= A->n ) + error(E_BOUNDS,"scan_to"); + if ( row_num < 0 ) + { + idx = col; + continue; + } + r = &(A->row[row_num]); + if ( idx < 0 ) + error(E_INTERN,"scan_to"); + e = &(r->elt[idx]); + if ( e->col != col ) + error(E_INTERN,"scan_to"); + if ( idx < 0 ) + { + printf("scan_to: row_num = %d, idx = %d, col = %d\n", + row_num, idx, col); + error(E_INTERN,"scan_to"); + } + /* if ( e->nxt_row <= max_row ) + chase_col(A, col, &row_num, &idx, max_row); */ + while ( e->nxt_row >= 0 && e->nxt_row <= max_row ) + { + row_num = e->nxt_row; + idx = e->nxt_idx; + e = &(A->row[row_num].elt[idx]); + } + + /* printf("scan_to: computed j_idx = %d, row_num = %d, idx = %d\n", + j_idx, row_num, idx); */ + scan_row->ive[j_idx] = row_num; + scan_idx->ive[j_idx] = idx; + } +} + +/* patch_col -- patches column access paths for fill-in */ +void patch_col(A, col, old_row, old_idx, row_num, idx) +SPMAT *A; +int col, old_row, old_idx, row_num, idx; +{ + SPROW *r; + row_elt *e; + + if ( old_row >= 0 ) + { + r = &(A->row[old_row]); + old_idx = sprow_idx2(r,col,old_idx); + e = &(r->elt[old_idx]); + e->nxt_row = row_num; + e->nxt_idx = idx; + } + else + { + A->start_row[col] = row_num; + A->start_idx[col] = idx; + } +} + +/* chase_col -- chases column access path in column col, starting with + row_num and idx, to find last row # in this column <= max_row + -- row_num is returned; idx is also set by this routine + -- assumes that the column access paths (possibly without the + nxt_idx fields) are set up */ +row_elt *chase_col(A, col, row_num, idx, max_row) +SPMAT *A; +int col, *row_num, *idx, max_row; +{ + int old_idx, old_row, tmp_idx, tmp_row; + SPROW *r; + row_elt *e; + + if ( col < 0 || col >= A->n ) + error(E_BOUNDS,"chase_col"); + tmp_row = *row_num; + if ( tmp_row < 0 ) + { + if ( A->start_row[col] > max_row ) + { + tmp_row = -1; + tmp_idx = col; + return (row_elt *)NULL; + } + else + { + tmp_row = A->start_row[col]; + tmp_idx = A->start_idx[col]; + } + } + else + tmp_idx = *idx; + + old_row = tmp_row; + old_idx = tmp_idx; + while ( tmp_row >= 0 && tmp_row < max_row ) + { + r = &(A->row[tmp_row]); + /* tmp_idx = sprow_idx2(r,col,tmp_idx); */ + if ( tmp_idx < 0 || tmp_idx >= r->len || + r->elt[tmp_idx].col != col ) + { +#ifdef DEBUG + printf("chase_col:error: col = %d, row # = %d, idx = %d\n", + col, tmp_row, tmp_idx); + printf("chase_col:error: old_row = %d, old_idx = %d\n", + old_row, old_idx); + printf("chase_col:error: A =\n"); + sp_dump(stdout,A); +#endif + error(E_INTERN,"chase_col"); + } + e = &(r->elt[tmp_idx]); + old_row = tmp_row; + old_idx = tmp_idx; + tmp_row = e->nxt_row; + tmp_idx = e->nxt_idx; + } + if ( old_row > max_row ) + { + old_row = -1; + old_idx = col; + e = (row_elt *)NULL; + } + else if ( tmp_row <= max_row && tmp_row >= 0 ) + { + old_row = tmp_row; + old_idx = tmp_idx; + } + + *row_num = old_row; + if ( old_row >= 0 ) + *idx = old_idx; + else + *idx = col; + + return e; +} + +/* chase_past -- as for chase_col except that we want the first + row whose row # >= min_row; -1 indicates no such row */ +row_elt *chase_past(A, col, row_num, idx, min_row) +SPMAT *A; +int col, *row_num, *idx, min_row; +{ + SPROW *r; + row_elt *e; + int tmp_idx, tmp_row; + + tmp_row = *row_num; + tmp_idx = *idx; + chase_col(A,col,&tmp_row,&tmp_idx,min_row); + if ( tmp_row < 0 ) /* use A->start_row[..] etc. */ + { + if ( A->start_row[col] < 0 ) + tmp_row = -1; + else + { + tmp_row = A->start_row[col]; + tmp_idx = A->start_idx[col]; + } + } + else if ( tmp_row < min_row ) + { + r = &(A->row[tmp_row]); + if ( tmp_idx < 0 || tmp_idx >= r->len || + r->elt[tmp_idx].col != col ) + error(E_INTERN,"chase_past"); + tmp_row = r->elt[tmp_idx].nxt_row; + tmp_idx = r->elt[tmp_idx].nxt_idx; + } + + *row_num = tmp_row; + *idx = tmp_idx; + if ( tmp_row < 0 ) + e = (row_elt *)NULL; + else + { + if ( tmp_idx < 0 || tmp_idx >= A->row[tmp_row].len || + A->row[tmp_row].elt[tmp_idx].col != col ) + error(E_INTERN,"bump_col"); + e = &(A->row[tmp_row].elt[tmp_idx]); + } + + return e; +} + +/* bump_col -- move along to next nonzero entry in column col after row_num + -- update row_num and idx */ +row_elt *bump_col(A, col, row_num, idx) +SPMAT *A; +int col, *row_num, *idx; +{ + SPROW *r; + row_elt *e; + int tmp_row, tmp_idx; + + tmp_row = *row_num; + tmp_idx = *idx; + /* printf("bump_col: col = %d, row# = %d, idx = %d\n", + col, *row_num, *idx); */ + if ( tmp_row < 0 ) + { + tmp_row = A->start_row[col]; + tmp_idx = A->start_idx[col]; + } + else + { + r = &(A->row[tmp_row]); + if ( tmp_idx < 0 || tmp_idx >= r->len || + r->elt[tmp_idx].col != col ) + error(E_INTERN,"bump_col"); + e = &(r->elt[tmp_idx]); + tmp_row = e->nxt_row; + tmp_idx = e->nxt_idx; + } + if ( tmp_row < 0 ) + { + e = (row_elt *)NULL; + tmp_idx = col; + } + else + { + if ( tmp_idx < 0 || tmp_idx >= A->row[tmp_row].len || + A->row[tmp_row].elt[tmp_idx].col != col ) + error(E_INTERN,"bump_col"); + e = &(A->row[tmp_row].elt[tmp_idx]); + } + *row_num = tmp_row; + *idx = tmp_idx; + + return e; +} + + diff --git a/meschach/sptort.c b/meschach/sptort.c new file mode 100644 index 0000000..2d1de9a --- /dev/null +++ b/meschach/sptort.c @@ -0,0 +1,485 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + This file contains tests for the sparse matrix part of Meschach +*/ + +#include +#include +#include "matrix2.h" +#include "sparse2.h" +#include "iter.h" + +#define errmesg(mesg) printf("Error: %s error: line %d\n",mesg,__LINE__) +#define notice(mesg) printf("# Testing %s...\n",mesg); + +/* for iterative methods */ + +#if REAL == DOUBLE +#define EPS 1e-7 +#elif REAL == FLOAT +#define EPS 1e-3 +#endif + +int chk_col_access(A) +SPMAT *A; +{ + int i, j, nxt_idx, nxt_row, scan_cnt, total_cnt; + SPROW *r; + row_elt *e; + + if ( ! A ) + error(E_NULL,"chk_col_access"); + if ( ! A->flag_col ) + return FALSE; + + /* scan down each column, counting the number of entries met */ + scan_cnt = 0; + for ( j = 0; j < A->n; j++ ) + { + i = -1; + nxt_idx = A->start_idx[j]; + nxt_row = A->start_row[j]; + while ( nxt_row >= 0 && nxt_idx >= 0 && nxt_row > i ) + { + i = nxt_row; + r = &(A->row[i]); + e = &(r->elt[nxt_idx]); + nxt_idx = e->nxt_idx; + nxt_row = e->nxt_row; + scan_cnt++; + } + } + + total_cnt = 0; + for ( i = 0; i < A->m; i++ ) + total_cnt += A->row[i].len; + if ( total_cnt != scan_cnt ) + return FALSE; + else + return TRUE; +} + + +void main(argc, argv) +int argc; +char *argv[]; +{ + VEC *x, *y, *z, *u, *v; + Real s1, s2; + PERM *pivot; + SPMAT *A, *B, *C; + SPMAT *B1, *C1; + SPROW *r; + int i, j, k, deg, seed, m, m_old, n, n_old; + + + mem_info_on(TRUE); + + setbuf(stdout, (char *)NULL); + /* get seed if in argument list */ + if ( argc == 1 ) + seed = 1111; + else if ( argc == 2 && sscanf(argv[1],"%d",&seed) == 1 ) + ; + else + { + printf("usage: %s [seed]\n", argv[0]); + exit(0); + } + srand(seed); + + /* set up two random sparse matrices */ + m = 120; + n = 100; + deg = 8; + notice("allocating sparse matrices"); + A = sp_get(m,n,deg); + B = sp_get(m,n,deg); + notice("setting and getting matrix entries"); + for ( k = 0; k < m*deg; k++ ) + { + i = (rand() >> 8) % m; + j = (rand() >> 8) % n; + sp_set_val(A,i,j,rand()/((Real)MAX_RAND)); + i = (rand() >> 8) % m; + j = (rand() >> 8) % n; + sp_set_val(B,i,j,rand()/((Real)MAX_RAND)); + } + for ( k = 0; k < 10; k++ ) + { + s1 = rand()/((Real)MAX_RAND); + i = (rand() >> 8) % m; + j = (rand() >> 8) % n; + sp_set_val(A,i,j,s1); + s2 = sp_get_val(A,i,j); + if ( fabs(s1 - s2) >= MACHEPS ) + break; + } + if ( k < 10 ) + errmesg("sp_set_val()/sp_get_val()"); + + /* test copy routines */ + notice("copy routines"); + x = v_get(n); + y = v_get(m); + z = v_get(m); + /* first copy routine */ + C = sp_copy(A); + for ( k = 0; k < 100; k++ ) + { + v_rand(x); + sp_mv_mlt(A,x,y); + sp_mv_mlt(C,x,z); + if ( v_norm_inf(v_sub(y,z,z)) >= MACHEPS*deg*m ) + break; + } + if ( k < 100 ) + { + errmesg("sp_copy()/sp_mv_mlt()"); + printf("# Error in A.x (inf norm) = %g [cf MACHEPS = %g]\n", + v_norm_inf(z), MACHEPS); + } + /* second copy routine + -- note that A & B have different sparsity patterns */ + + mem_stat_mark(1); + sp_copy2(A,B); + mem_stat_free(1); + for ( k = 0; k < 10; k++ ) + { + v_rand(x); + sp_mv_mlt(A,x,y); + sp_mv_mlt(B,x,z); + if ( v_norm_inf(v_sub(y,z,z)) >= MACHEPS*deg*m ) + break; + } + if ( k < 10 ) + { + errmesg("sp_copy2()/sp_mv_mlt()"); + printf("# Error in A.x (inf norm) = %g [cf MACHEPS = %g]\n", + v_norm_inf(z), MACHEPS); + } + + /* now check compacting routine */ + notice("compacting routine"); + sp_compact(B,0.0); + for ( k = 0; k < 10; k++ ) + { + v_rand(x); + sp_mv_mlt(A,x,y); + sp_mv_mlt(B,x,z); + if ( v_norm_inf(v_sub(y,z,z)) >= MACHEPS*deg*m ) + break; + } + if ( k < 10 ) + { + errmesg("sp_compact()"); + printf("# Error in A.x (inf norm) = %g [cf MACHEPS = %g]\n", + v_norm_inf(z), MACHEPS); + } + for ( i = 0; i < B->m; i++ ) + { + r = &(B->row[i]); + for ( j = 0; j < r->len; j++ ) + if ( r->elt[j].val == 0.0 ) + break; + } + if ( i < B->m ) + { + errmesg("sp_compact()"); + printf("# Zero entry in compacted matrix\n"); + } + + /* check column access paths */ + notice("resizing and access paths"); + m_old = A->m-1; + n_old = A->n-1; + A = sp_resize(A,A->m+10,A->n+10); + for ( k = 0 ; k < 20; k++ ) + { + i = m_old + ((rand() >> 8) % 10); + j = n_old + ((rand() >> 8) % 10); + s1 = rand()/((Real)MAX_RAND); + sp_set_val(A,i,j,s1); + if ( fabs(s1 - sp_get_val(A,i,j)) >= MACHEPS ) + break; + } + if ( k < 20 ) + errmesg("sp_resize()"); + sp_col_access(A); + if ( ! chk_col_access(A) ) + { + errmesg("sp_col_access()"); + } + sp_diag_access(A); + for ( i = 0; i < A->m; i++ ) + { + r = &(A->row[i]); + if ( r->diag != sprow_idx(r,i) ) + break; + } + if ( i < A->m ) + { + errmesg("sp_diag_access()"); + } + + /* test both sp_mv_mlt() and sp_vm_mlt() */ + x = v_resize(x,B->n); + y = v_resize(y,B->m); + u = v_get(B->m); + v = v_get(B->n); + for ( k = 0; k < 10; k++ ) + { + v_rand(x); + v_rand(y); + sp_mv_mlt(B,x,u); + sp_vm_mlt(B,y,v); + if ( fabs(in_prod(x,v) - in_prod(y,u)) >= + MACHEPS*v_norm2(x)*v_norm2(u)*5 ) + break; + } + if ( k < 10 ) + { + errmesg("sp_mv_mlt()/sp_vm_mlt()"); + printf("# Error in inner products = %g [cf MACHEPS = %g]\n", + fabs(in_prod(x,v) - in_prod(y,u)), MACHEPS); + } + + SP_FREE(A); + SP_FREE(B); + SP_FREE(C); + + /* now test Cholesky and LU factorise and solve */ + notice("sparse Cholesky factorise/solve"); + A = iter_gen_sym(120,8); + B = sp_copy(A); + spCHfactor(A); + x = v_resize(x,A->m); + y = v_resize(y,A->m); + v_rand(x); + sp_mv_mlt(B,x,y); + z = v_resize(z,A->m); + spCHsolve(A,y,z); + v = v_resize(v,A->m); + sp_mv_mlt(B,z,v); + /* compute residual */ + v_sub(y,v,v); + if ( v_norm2(v) >= MACHEPS*v_norm2(y)*10 ) + { + errmesg("spCHfactor()/spCHsolve()"); + printf("# Sparse Cholesky residual = %g [cf MACHEPS = %g]\n", + v_norm2(v), MACHEPS); + } + /* compute error in solution */ + v_sub(x,z,z); + if ( v_norm2(z) > MACHEPS*v_norm2(x)*10 ) + { + errmesg("spCHfactor()/spCHsolve()"); + printf("# Solution error = %g [cf MACHEPS = %g]\n", + v_norm2(z), MACHEPS); + } + + /* now test symbolic and incomplete factorisation */ + SP_FREE(A); + A = sp_copy(B); + + mem_stat_mark(2); + spCHsymb(A); + mem_stat_mark(2); + + spICHfactor(A); + spCHsolve(A,y,z); + v = v_resize(v,A->m); + sp_mv_mlt(B,z,v); + /* compute residual */ + v_sub(y,v,v); + if ( v_norm2(v) >= MACHEPS*v_norm2(y)*5 ) + { + errmesg("spCHsymb()/spICHfactor()"); + printf("# Sparse Cholesky residual = %g [cf MACHEPS = %g]\n", + v_norm2(v), MACHEPS); + } + /* compute error in solution */ + v_sub(x,z,z); + if ( v_norm2(z) > MACHEPS*v_norm2(x)*10 ) + { + errmesg("spCHsymb()/spICHfactor()"); + printf("# Solution error = %g [cf MACHEPS = %g]\n", + v_norm2(z), MACHEPS); + } + + /* now test sparse LU factorisation */ + notice("sparse LU factorise/solve"); + SP_FREE(A); + SP_FREE(B); + A = iter_gen_nonsym(100,100,8,1.0); + + B = sp_copy(A); + x = v_resize(x,A->n); + z = v_resize(z,A->n); + y = v_resize(y,A->m); + v = v_resize(v,A->m); + + v_rand(x); + sp_mv_mlt(B,x,y); + pivot = px_get(A->m); + + mem_stat_mark(3); + spLUfactor(A,pivot,0.1); + spLUsolve(A,pivot,y,z); + mem_stat_free(3); + sp_mv_mlt(B,z,v); + + /* compute residual */ + v_sub(y,v,v); + if ( v_norm2(v) >= MACHEPS*v_norm2(y)*A->m ) + { + errmesg("spLUfactor()/spLUsolve()"); + printf("# Sparse LU residual = %g [cf MACHEPS = %g]\n", + v_norm2(v), MACHEPS); + } + /* compute error in solution */ + v_sub(x,z,z); + if ( v_norm2(z) > MACHEPS*v_norm2(x)*100*A->m ) + { + errmesg("spLUfactor()/spLUsolve()"); + printf("# Sparse LU solution error = %g [cf MACHEPS = %g]\n", + v_norm2(z), MACHEPS); + } + + /* now check spLUTsolve */ + mem_stat_mark(4); + sp_vm_mlt(B,x,y); + spLUTsolve(A,pivot,y,z); + sp_vm_mlt(B,z,v); + mem_stat_free(4); + + /* compute residual */ + v_sub(y,v,v); + if ( v_norm2(v) >= MACHEPS*v_norm2(y)*A->m ) + { + errmesg("spLUTsolve()"); + printf("# Sparse LU residual = %g [cf MACHEPS = %g]\n", + v_norm2(v), MACHEPS); + } + /* compute error in solution */ + v_sub(x,z,z); + if ( v_norm2(z) > MACHEPS*v_norm2(x)*100*A->m ) + { + errmesg("spLUTsolve()"); + printf("# Sparse LU solution error = %g [cf MACHEPS = %g]\n", + v_norm2(z), MACHEPS); + } + + /* algebraic operations */ + notice("addition,subtraction and multiplying by a number"); + SP_FREE(A); + SP_FREE(B); + + m = 120; + n = 120; + deg = 5; + A = sp_get(m,n,deg); + B = sp_get(m,n,deg); + C = sp_get(m,n,deg); + C1 = sp_get(m,n,deg); + + for ( k = 0; k < m*deg; k++ ) + { + i = (rand() >> 8) % m; + j = (rand() >> 8) % n; + sp_set_val(A,i,j,rand()/((Real)MAX_RAND)); + i = (rand() >> 8) % m; + j = (rand() >> 8) % n; + sp_set_val(B,i,j,rand()/((Real)MAX_RAND)); + } + + s1 = mrand(); + B1 = sp_copy(B); + + mem_stat_mark(1); + sp_smlt(B,s1,C); + sp_add(A,C,C1); + sp_sub(C1,A,C); + sp_smlt(C,-1.0/s1,C); + sp_add(C,B1,C); + + s2 = 0.0; + for (k=0; k < C->m; k++) { + r = &(C->row[k]); + for (j=0; j < r->len; j++) { + if (s2 < fabs(r->elt[j].val)) + s2 = fabs(r->elt[j].val); + } + } + + if (s2 > MACHEPS*A->m) { + errmesg("add, sub, mlt sparse matrices (args not in situ)\n"); + printf(" difference = %g [MACEPS = %g]\n",s2,MACHEPS); + } + + sp_mltadd(A,B1,s1,C1); + sp_sub(C1,A,A); + sp_smlt(A,1.0/s1,C1); + sp_sub(C1,B1,C1); + mem_stat_free(1); + + s2 = 0.0; + for (k=0; k < C1->m; k++) { + r = &(C1->row[k]); + for (j=0; j < r->len; j++) { + if (s2 < fabs(r->elt[j].val)) + s2 = fabs(r->elt[j].val); + } + } + + if (s2 > MACHEPS*A->m) { + errmesg("add, sub, mlt sparse matrices (args not in situ)\n"); + printf(" difference = %g [MACEPS = %g]\n",s2,MACHEPS); + } + + V_FREE(x); + V_FREE(y); + V_FREE(z); + V_FREE(u); + V_FREE(v); + PX_FREE(pivot); + SP_FREE(A); + SP_FREE(B); + SP_FREE(C); + SP_FREE(B1); + SP_FREE(C1); + + printf("# Done testing (%s)\n",argv[0]); + mem_info(); +} + + + + + diff --git a/meschach/sputil.h b/meschach/sputil.h new file mode 100644 index 0000000..0c71716 --- /dev/null +++ b/meschach/sputil.h @@ -0,0 +1,27 @@ +/* Sparse matrix utility macros */ +/* (C) Copyright David Stewart Fri 25th Sep 1992, 04:34:41 PM */ +/* This file contains macros for making life with sparse matrices easier */ + +/* loop over the columns in a row */ +#define loop_cols(r,e,code) \ + do { int _r_idx; row_elt *e; sp_row *_t_row; \ + _t_row = (r); e = &(_t_row->elt); \ + for ( _r_idx = 0; _r_idx < _t_row->len; _r_idx++, e++ ) \ + { code; } } while ( 0 ) + +/* loop over the rows in a column */ +#define loop_cols(A,col,e,code) \ + do { int _r_num, _r_idx, _c; sp_row *_r; row_elt *e; \ + if ( ! (A)->flag_col ) sp_col_access((A)); \ + col_num = (col); \ + if ( col_num < 0 || col_num >= A->n ) \ + error(E_BOUNDS,"loop_cols"); \ + _r_num = (A)->start_row[_c]; _r_idx = (A)->start_idx[_c]; \ + while ( _r_num >= 0 ) { \ + _r = &((A)->row[_r_num]); \ + _r_idx = sp_get_idx2(_r,_c,_r_idx); \ + if ( _r_idx < 0 ) continue; \ + e = &(_r->elt[_r_idx]); code; \ + _r_num = e->nxt_row; _r_idx = e->nxt_idx; \ + } } while ( 0 ) + diff --git a/meschach/submat.c b/meschach/submat.c new file mode 100644 index 0000000..bbd4f8c --- /dev/null +++ b/meschach/submat.c @@ -0,0 +1,178 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* 1.2 submat.c 11/25/87 */ + +#include +#include "matrix.h" + +static char rcsid[] = "$Id: submat.c,v 1.1 2001/03/01 17:19:10 rfranke Exp $"; + + +/* get_col -- gets a specified column of a matrix and retruns it as a vector */ +VEC *get_col(mat,col,vec) +u_int col; +MAT *mat; +VEC *vec; +{ + u_int i; + + if ( mat==(MAT *)NULL ) + error(E_NULL,"get_col"); + if ( col >= mat->n ) + error(E_RANGE,"get_col"); + if ( vec==(VEC *)NULL || vec->dimm ) + vec = v_resize(vec,mat->m); + + for ( i=0; im; i++ ) + vec->ve[i] = mat->me[i][col]; + + return (vec); +} + +/* get_row -- gets a specified row of a matrix and retruns it as a vector */ +VEC *get_row(mat,row,vec) +u_int row; +MAT *mat; +VEC *vec; +{ + u_int i; + + if ( mat==(MAT *)NULL ) + error(E_NULL,"get_row"); + if ( row >= mat->m ) + error(E_RANGE,"get_row"); + if ( vec==(VEC *)NULL || vec->dimn ) + vec = v_resize(vec,mat->n); + + for ( i=0; in; i++ ) + vec->ve[i] = mat->me[row][i]; + + return (vec); +} + +/* _set_col -- sets column of matrix to values given in vec (in situ) */ +MAT *_set_col(mat,col,vec,i0) +MAT *mat; +VEC *vec; +u_int col,i0; +{ + u_int i,lim; + + if ( mat==(MAT *)NULL || vec==(VEC *)NULL ) + error(E_NULL,"_set_col"); + if ( col >= mat->n ) + error(E_RANGE,"_set_col"); + lim = min(mat->m,vec->dim); + for ( i=i0; ime[i][col] = vec->ve[i]; + + return (mat); +} + +/* _set_row -- sets row of matrix to values given in vec (in situ) */ +MAT *_set_row(mat,row,vec,j0) +MAT *mat; +VEC *vec; +u_int row,j0; +{ + u_int j,lim; + + if ( mat==(MAT *)NULL || vec==(VEC *)NULL ) + error(E_NULL,"_set_row"); + if ( row >= mat->m ) + error(E_RANGE,"_set_row"); + lim = min(mat->n,vec->dim); + for ( j=j0; jme[row][j] = vec->ve[j]; + + return (mat); +} + +/* sub_mat -- returns sub-matrix of old which is formed by the rectangle + from (row1,col1) to (row2,col2) + -- Note: storage is shared so that altering the "new" + matrix will alter the "old" matrix */ +MAT *sub_mat(old,row1,col1,row2,col2,new) +MAT *old,*new; +u_int row1,col1,row2,col2; +{ + u_int i; + + if ( old==(MAT *)NULL ) + error(E_NULL,"sub_mat"); + if ( row1 > row2 || col1 > col2 || row2 >= old->m || col2 >= old->n ) + error(E_RANGE,"sub_mat"); + if ( new==(MAT *)NULL || new->m < row2-row1+1 ) + { + new = NEW(MAT); + new->me = NEW_A(row2-row1+1,Real *); + if ( new==(MAT *)NULL || new->me==(Real **)NULL ) + error(E_MEM,"sub_mat"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_MAT,0,sizeof(MAT)+ + (row2-row1+1)*sizeof(Real *)); + } + + } + new->m = row2-row1+1; + + new->n = col2-col1+1; + + new->base = (Real *)NULL; + + for ( i=0; i < new->m; i++ ) + new->me[i] = (old->me[i+row1]) + col1; + + return (new); +} + + +/* sub_vec -- returns sub-vector which is formed by the elements i1 to i2 + -- as for sub_mat, storage is shared */ +VEC *sub_vec(old,i1,i2,new) +VEC *old, *new; +int i1, i2; +{ + if ( old == (VEC *)NULL ) + error(E_NULL,"sub_vec"); + if ( i1 > i2 || old->dim < i2 ) + error(E_RANGE,"sub_vec"); + + if ( new == (VEC *)NULL ) + new = NEW(VEC); + if ( new == (VEC *)NULL ) + error(E_MEM,"sub_vec"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_VEC,0,sizeof(VEC)); + } + + + new->dim = i2 - i1 + 1; + new->ve = &(old->ve[i1]); + + return new; +} diff --git a/meschach/svd.c b/meschach/svd.c new file mode 100644 index 0000000..2254b57 --- /dev/null +++ b/meschach/svd.c @@ -0,0 +1,400 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + File containing routines for computing the SVD of matrices +*/ + +#include +#include +#include "matrix.h" +#include "matrix2.h" + + +static char rcsid[] = "$Id: svd.c,v 1.1 2001/03/01 17:19:10 rfranke Exp $"; + + + +#define sgn(x) ((x) >= 0 ? 1 : -1) +#define MAX_STACK 100 + +/* fixsvd -- fix minor details about SVD + -- make singular values non-negative + -- sort singular values in decreasing order + -- variables as for bisvd() + -- no argument checking */ +static void fixsvd(d,U,V) +VEC *d; +MAT *U, *V; +{ + int i, j, k, l, r, stack[MAX_STACK], sp; + Real tmp, v; + + /* make singular values non-negative */ + for ( i = 0; i < d->dim; i++ ) + if ( d->ve[i] < 0.0 ) + { + d->ve[i] = - d->ve[i]; + if ( U != MNULL ) + for ( j = 0; j < U->m; j++ ) + U->me[i][j] = - U->me[i][j]; + } + + /* sort singular values */ + /* nonrecursive implementation of quicksort due to R.Sedgewick, + "Algorithms in C", p. 122 (1990) */ + sp = -1; + l = 0; r = d->dim - 1; + for ( ; ; ) + { + while ( r > l ) + { + /* i = partition(d->ve,l,r) */ + v = d->ve[r]; + + i = l - 1; j = r; + for ( ; ; ) + { /* inequalities are "backwards" for **decreasing** order */ + while ( d->ve[++i] > v ) + ; + while ( d->ve[--j] < v ) + ; + if ( i >= j ) + break; + /* swap entries in d->ve */ + tmp = d->ve[i]; d->ve[i] = d->ve[j]; d->ve[j] = tmp; + /* swap rows of U & V as well */ + if ( U != MNULL ) + for ( k = 0; k < U->n; k++ ) + { + tmp = U->me[i][k]; + U->me[i][k] = U->me[j][k]; + U->me[j][k] = tmp; + } + if ( V != MNULL ) + for ( k = 0; k < V->n; k++ ) + { + tmp = V->me[i][k]; + V->me[i][k] = V->me[j][k]; + V->me[j][k] = tmp; + } + } + tmp = d->ve[i]; d->ve[i] = d->ve[r]; d->ve[r] = tmp; + if ( U != MNULL ) + for ( k = 0; k < U->n; k++ ) + { + tmp = U->me[i][k]; + U->me[i][k] = U->me[r][k]; + U->me[r][k] = tmp; + } + if ( V != MNULL ) + for ( k = 0; k < V->n; k++ ) + { + tmp = V->me[i][k]; + V->me[i][k] = V->me[r][k]; + V->me[r][k] = tmp; + } + /* end i = partition(...) */ + if ( i - l > r - i ) + { stack[++sp] = l; stack[++sp] = i-1; l = i+1; } + else + { stack[++sp] = i+1; stack[++sp] = r; r = i-1; } + } + if ( sp < 0 ) + break; + r = stack[sp--]; l = stack[sp--]; + } +} + + +/* bisvd -- svd of a bidiagonal m x n matrix represented by d (diagonal) and + f (super-diagonals) + -- returns with d set to the singular values, f zeroed + -- if U, V non-NULL, the orthogonal operations are accumulated + in U, V; if U, V == I on entry, then SVD == U^T.A.V + where A is initial matrix + -- returns d on exit */ +VEC *bisvd(d,f,U,V) +VEC *d, *f; +MAT *U, *V; +{ + int i, j, n; + int i_min, i_max, split; + Real c, s, shift, size, z; + Real d_tmp, diff, t11, t12, t22, *d_ve, *f_ve; + + if ( ! d || ! f ) + error(E_NULL,"bisvd"); + if ( d->dim != f->dim + 1 ) + error(E_SIZES,"bisvd"); + n = d->dim; + if ( ( U && U->n < n ) || ( V && V->m < n ) ) + error(E_SIZES,"bisvd"); + if ( ( U && U->m != U->n ) || ( V && V->m != V->n ) ) + error(E_SQUARE,"bisvd"); + + + if ( n == 1 ) + return d; + d_ve = d->ve; f_ve = f->ve; + + size = v_norm_inf(d) + v_norm_inf(f); + + i_min = 0; + while ( i_min < n ) /* outer while loop */ + { + /* find i_max to suit; + submatrix i_min..i_max should be irreducible */ + i_max = n - 1; + for ( i = i_min; i < n - 1; i++ ) + if ( d_ve[i] == 0.0 || f_ve[i] == 0.0 ) + { i_max = i; + if ( f_ve[i] != 0.0 ) + { + /* have to ``chase'' f[i] element out of matrix */ + z = f_ve[i]; f_ve[i] = 0.0; + for ( j = i; j < n-1 && z != 0.0; j++ ) + { + givens(d_ve[j+1],z, &c, &s); + s = -s; + d_ve[j+1] = c*d_ve[j+1] - s*z; + if ( j+1 < n-1 ) + { + z = s*f_ve[j+1]; + f_ve[j+1] = c*f_ve[j+1]; + } + if ( U ) + rot_rows(U,i,j+1,c,s,U); + } + } + break; + } + if ( i_max <= i_min ) + { + i_min = i_max + 1; + continue; + } + /* printf("bisvd: i_min = %d, i_max = %d\n",i_min,i_max); */ + + split = FALSE; + while ( ! split ) + { + /* compute shift */ + t11 = d_ve[i_max-1]*d_ve[i_max-1] + + (i_max > i_min+1 ? f_ve[i_max-2]*f_ve[i_max-2] : 0.0); + t12 = d_ve[i_max-1]*f_ve[i_max-1]; + t22 = d_ve[i_max]*d_ve[i_max] + f_ve[i_max-1]*f_ve[i_max-1]; + /* use e-val of [[t11,t12],[t12,t22]] matrix + closest to t22 */ + diff = (t11-t22)/2; + shift = t22 - t12*t12/(diff + + sgn(diff)*sqrt(diff*diff+t12*t12)); + + /* initial Givens' rotation */ + givens(d_ve[i_min]*d_ve[i_min]-shift, + d_ve[i_min]*f_ve[i_min], &c, &s); + + /* do initial Givens' rotations */ + d_tmp = c*d_ve[i_min] + s*f_ve[i_min]; + f_ve[i_min] = c*f_ve[i_min] - s*d_ve[i_min]; + d_ve[i_min] = d_tmp; + z = s*d_ve[i_min+1]; + d_ve[i_min+1] = c*d_ve[i_min+1]; + if ( V ) + rot_rows(V,i_min,i_min+1,c,s,V); + /* 2nd Givens' rotation */ + givens(d_ve[i_min],z, &c, &s); + d_ve[i_min] = c*d_ve[i_min] + s*z; + d_tmp = c*d_ve[i_min+1] - s*f_ve[i_min]; + f_ve[i_min] = s*d_ve[i_min+1] + c*f_ve[i_min]; + d_ve[i_min+1] = d_tmp; + if ( i_min+1 < i_max ) + { + z = s*f_ve[i_min+1]; + f_ve[i_min+1] = c*f_ve[i_min+1]; + } + if ( U ) + rot_rows(U,i_min,i_min+1,c,s,U); + + for ( i = i_min+1; i < i_max; i++ ) + { + /* get Givens' rotation for zeroing z */ + givens(f_ve[i-1],z, &c, &s); + f_ve[i-1] = c*f_ve[i-1] + s*z; + d_tmp = c*d_ve[i] + s*f_ve[i]; + f_ve[i] = c*f_ve[i] - s*d_ve[i]; + d_ve[i] = d_tmp; + z = s*d_ve[i+1]; + d_ve[i+1] = c*d_ve[i+1]; + if ( V ) + rot_rows(V,i,i+1,c,s,V); + /* get 2nd Givens' rotation */ + givens(d_ve[i],z, &c, &s); + d_ve[i] = c*d_ve[i] + s*z; + d_tmp = c*d_ve[i+1] - s*f_ve[i]; + f_ve[i] = c*f_ve[i] + s*d_ve[i+1]; + d_ve[i+1] = d_tmp; + if ( i+1 < i_max ) + { + z = s*f_ve[i+1]; + f_ve[i+1] = c*f_ve[i+1]; + } + if ( U ) + rot_rows(U,i,i+1,c,s,U); + } + /* should matrix be split? */ + for ( i = i_min; i < i_max; i++ ) + if ( fabs(f_ve[i]) < + MACHEPS*(fabs(d_ve[i])+fabs(d_ve[i+1])) ) + { + split = TRUE; + f_ve[i] = 0.0; + } + else if ( fabs(d_ve[i]) < MACHEPS*size ) + { + split = TRUE; + d_ve[i] = 0.0; + } + /* printf("bisvd: d =\n"); v_output(d); */ + /* printf("bisvd: f = \n"); v_output(f); */ + } + } + fixsvd(d,U,V); + + return d; +} + +/* bifactor -- perform preliminary factorisation for bisvd + -- updates U and/or V, which ever is not NULL */ +MAT *bifactor(A,U,V) +MAT *A, *U, *V; +{ + int k; + static VEC *tmp1=VNULL, *tmp2=VNULL; + Real beta; + + if ( ! A ) + error(E_NULL,"bifactor"); + if ( ( U && ( U->m != U->n ) ) || ( V && ( V->m != V->n ) ) ) + error(E_SQUARE,"bifactor"); + if ( ( U && U->m != A->m ) || ( V && V->m != A->n ) ) + error(E_SIZES,"bifactor"); + tmp1 = v_resize(tmp1,A->m); + tmp2 = v_resize(tmp2,A->n); + MEM_STAT_REG(tmp1,TYPE_VEC); + MEM_STAT_REG(tmp2,TYPE_VEC); + + if ( A->m >= A->n ) + for ( k = 0; k < A->n; k++ ) + { + get_col(A,k,tmp1); + hhvec(tmp1,k,&beta,tmp1,&(A->me[k][k])); + hhtrcols(A,k,k+1,tmp1,beta); + if ( U ) + hhtrcols(U,k,0,tmp1,beta); + if ( k+1 >= A->n ) + continue; + get_row(A,k,tmp2); + hhvec(tmp2,k+1,&beta,tmp2,&(A->me[k][k+1])); + hhtrrows(A,k+1,k+1,tmp2,beta); + if ( V ) + hhtrcols(V,k+1,0,tmp2,beta); + } + else + for ( k = 0; k < A->m; k++ ) + { + get_row(A,k,tmp2); + hhvec(tmp2,k,&beta,tmp2,&(A->me[k][k])); + hhtrrows(A,k+1,k,tmp2,beta); + if ( V ) + hhtrcols(V,k,0,tmp2,beta); + if ( k+1 >= A->m ) + continue; + get_col(A,k,tmp1); + hhvec(tmp1,k+1,&beta,tmp1,&(A->me[k+1][k])); + hhtrcols(A,k+1,k+1,tmp1,beta); + if ( U ) + hhtrcols(U,k+1,0,tmp1,beta); + } + + return A; +} + +/* svd -- returns vector of singular values in d + -- also updates U and/or V, if one or the other is non-NULL + -- destroys A */ +VEC *svd(A,U,V,d) +MAT *A, *U, *V; +VEC *d; +{ + static VEC *f=VNULL; + int i, limit; + MAT *A_tmp; + + if ( ! A ) + error(E_NULL,"svd"); + if ( ( U && ( U->m != U->n ) ) || ( V && ( V->m != V->n ) ) ) + error(E_SQUARE,"svd"); + if ( ( U && U->m != A->m ) || ( V && V->m != A->n ) ) + error(E_SIZES,"svd"); + + A_tmp = m_copy(A,MNULL); + if ( U != MNULL ) + m_ident(U); + if ( V != MNULL ) + m_ident(V); + limit = min(A_tmp->m,A_tmp->n); + d = v_resize(d,limit); + f = v_resize(f,limit-1); + MEM_STAT_REG(f,TYPE_VEC); + + bifactor(A_tmp,U,V); + if ( A_tmp->m >= A_tmp->n ) + for ( i = 0; i < limit; i++ ) + { + d->ve[i] = A_tmp->me[i][i]; + if ( i+1 < limit ) + f->ve[i] = A_tmp->me[i][i+1]; + } + else + for ( i = 0; i < limit; i++ ) + { + d->ve[i] = A_tmp->me[i][i]; + if ( i+1 < limit ) + f->ve[i] = A_tmp->me[i+1][i]; + } + + + if ( A_tmp->m >= A_tmp->n ) + bisvd(d,f,U,V); + else + bisvd(d,f,V,U); + + M_FREE(A_tmp); + + return d; +} + diff --git a/meschach/symmeig.c b/meschach/symmeig.c new file mode 100644 index 0000000..a9f6b84 --- /dev/null +++ b/meschach/symmeig.c @@ -0,0 +1,211 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + File containing routines for symmetric eigenvalue problems +*/ + +#include +#include +#include "matrix.h" +#include "matrix2.h" + + +static char rcsid[] = "$Id: symmeig.c,v 1.1 2001/03/01 17:19:11 rfranke Exp $"; + + + +#define SQRT2 1.4142135623730949 +#define sgn(x) ( (x) >= 0 ? 1 : -1 ) + +/* trieig -- finds eigenvalues of symmetric tridiagonal matrices + -- matrix represented by a pair of vectors a (diag entries) + and b (sub- & super-diag entries) + -- eigenvalues in a on return */ +VEC *trieig(a,b,Q) +VEC *a, *b; +MAT *Q; +{ + int i, i_min, i_max, n, split; + Real *a_ve, *b_ve; + Real b_sqr, bk, ak1, bk1, ak2, bk2, z; + Real c, c2, cs, s, s2, d, mu; + + if ( ! a || ! b ) + error(E_NULL,"trieig"); + if ( a->dim != b->dim + 1 || ( Q && Q->m != a->dim ) ) + error(E_SIZES,"trieig"); + if ( Q && Q->m != Q->n ) + error(E_SQUARE,"trieig"); + + n = a->dim; + a_ve = a->ve; b_ve = b->ve; + + i_min = 0; + while ( i_min < n ) /* outer while loop */ + { + /* find i_max to suit; + submatrix i_min..i_max should be irreducible */ + i_max = n-1; + for ( i = i_min; i < n-1; i++ ) + if ( b_ve[i] == 0.0 ) + { i_max = i; break; } + if ( i_max <= i_min ) + { + /* printf("# i_min = %d, i_max = %d\n",i_min,i_max); */ + i_min = i_max + 1; + continue; /* outer while loop */ + } + + /* printf("# i_min = %d, i_max = %d\n",i_min,i_max); */ + + /* repeatedly perform QR method until matrix splits */ + split = FALSE; + while ( ! split ) /* inner while loop */ + { + + /* find Wilkinson shift */ + d = (a_ve[i_max-1] - a_ve[i_max])/2; + b_sqr = b_ve[i_max-1]*b_ve[i_max-1]; + mu = a_ve[i_max] - b_sqr/(d + sgn(d)*sqrt(d*d+b_sqr)); + /* printf("# Wilkinson shift = %g\n",mu); */ + + /* initial Givens' rotation */ + givens(a_ve[i_min]-mu,b_ve[i_min],&c,&s); + s = -s; + /* printf("# c = %g, s = %g\n",c,s); */ + if ( fabs(c) < SQRT2 ) + { c2 = c*c; s2 = 1-c2; } + else + { s2 = s*s; c2 = 1-s2; } + cs = c*s; + ak1 = c2*a_ve[i_min]+s2*a_ve[i_min+1]-2*cs*b_ve[i_min]; + bk1 = cs*(a_ve[i_min]-a_ve[i_min+1]) + + (c2-s2)*b_ve[i_min]; + ak2 = s2*a_ve[i_min]+c2*a_ve[i_min+1]+2*cs*b_ve[i_min]; + bk2 = ( i_min < i_max-1 ) ? c*b_ve[i_min+1] : 0.0; + z = ( i_min < i_max-1 ) ? -s*b_ve[i_min+1] : 0.0; + a_ve[i_min] = ak1; + a_ve[i_min+1] = ak2; + b_ve[i_min] = bk1; + if ( i_min < i_max-1 ) + b_ve[i_min+1] = bk2; + if ( Q ) + rot_cols(Q,i_min,i_min+1,c,-s,Q); + /* printf("# z = %g\n",z); */ + /* printf("# a [temp1] =\n"); v_output(a); */ + /* printf("# b [temp1] =\n"); v_output(b); */ + + for ( i = i_min+1; i < i_max; i++ ) + { + /* get Givens' rotation for sub-block -- k == i-1 */ + givens(b_ve[i-1],z,&c,&s); + s = -s; + /* printf("# c = %g, s = %g\n",c,s); */ + + /* perform Givens' rotation on sub-block */ + if ( fabs(c) < SQRT2 ) + { c2 = c*c; s2 = 1-c2; } + else + { s2 = s*s; c2 = 1-s2; } + cs = c*s; + bk = c*b_ve[i-1] - s*z; + ak1 = c2*a_ve[i]+s2*a_ve[i+1]-2*cs*b_ve[i]; + bk1 = cs*(a_ve[i]-a_ve[i+1]) + + (c2-s2)*b_ve[i]; + ak2 = s2*a_ve[i]+c2*a_ve[i+1]+2*cs*b_ve[i]; + bk2 = ( i+1 < i_max ) ? c*b_ve[i+1] : 0.0; + z = ( i+1 < i_max ) ? -s*b_ve[i+1] : 0.0; + a_ve[i] = ak1; a_ve[i+1] = ak2; + b_ve[i] = bk1; + if ( i < i_max-1 ) + b_ve[i+1] = bk2; + if ( i > i_min ) + b_ve[i-1] = bk; + if ( Q ) + rot_cols(Q,i,i+1,c,-s,Q); + /* printf("# a [temp2] =\n"); v_output(a); */ + /* printf("# b [temp2] =\n"); v_output(b); */ + } + + /* test to see if matrix should be split */ + for ( i = i_min; i < i_max; i++ ) + if ( fabs(b_ve[i]) < MACHEPS* + (fabs(a_ve[i])+fabs(a_ve[i+1])) ) + { b_ve[i] = 0.0; split = TRUE; } + + /* printf("# a =\n"); v_output(a); */ + /* printf("# b =\n"); v_output(b); */ + } + } + + return a; +} + +/* symmeig -- computes eigenvalues of a dense symmetric matrix + -- A **must** be symmetric on entry + -- eigenvalues stored in out + -- Q contains orthogonal matrix of eigenvectors + -- returns vector of eigenvalues */ +VEC *symmeig(A,Q,out) +MAT *A, *Q; +VEC *out; +{ + int i; + static MAT *tmp = MNULL; + static VEC *b = VNULL, *diag = VNULL, *beta = VNULL; + + if ( ! A ) + error(E_NULL,"symmeig"); + if ( A->m != A->n ) + error(E_SQUARE,"symmeig"); + if ( ! out || out->dim != A->m ) + out = v_resize(out,A->m); + + tmp = m_copy(A,tmp); + b = v_resize(b,A->m - 1); + diag = v_resize(diag,(u_int)A->m); + beta = v_resize(beta,(u_int)A->m); + MEM_STAT_REG(tmp,TYPE_MAT); + MEM_STAT_REG(b,TYPE_VEC); + MEM_STAT_REG(diag,TYPE_VEC); + MEM_STAT_REG(beta,TYPE_VEC); + + Hfactor(tmp,diag,beta); + if ( Q ) + makeHQ(tmp,diag,beta,Q); + + for ( i = 0; i < A->m - 1; i++ ) + { + out->ve[i] = tmp->me[i][i]; + b->ve[i] = tmp->me[i][i+1]; + } + out->ve[i] = tmp->me[i][i]; + trieig(out,b,Q); + + return out; +} + diff --git a/meschach/torture.c b/meschach/torture.c new file mode 100644 index 0000000..961bc17 --- /dev/null +++ b/meschach/torture.c @@ -0,0 +1,1054 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + +/* + This file contains a series of tests for the Meschach matrix + library, parts 1 and 2 +*/ + +static char rcsid[] = "$Id: torture.c,v 1.1 2001/03/01 17:19:13 rfranke Exp $"; + +#include +#include +#include "matrix2.h" +#include "matlab.h" + +#define errmesg(mesg) printf("Error: %s error: line %d\n",mesg,__LINE__) +#define notice(mesg) printf("# Testing %s...\n",mesg); + +static char *test_err_list[] = { + "unknown error", /* 0 */ + "testing error messages", /* 1 */ + "unexpected end-of-file" /* 2 */ +}; + + +#define MAX_TEST_ERR (sizeof(test_err_list)/sizeof(char *)) + +/* extern int malloc_chain_check(); */ +/* #define MEMCHK() if ( malloc_chain_check(0) ) \ +{ printf("Error in malloc chain: \"%s\", line %d\n", \ + __FILE__, __LINE__); exit(0); } */ +#define MEMCHK() + +/* cmp_perm -- returns 1 if pi1 == pi2, 0 otherwise */ +int cmp_perm(pi1, pi2) +PERM *pi1, *pi2; +{ + int i; + + if ( ! pi1 || ! pi2 ) + error(E_NULL,"cmp_perm"); + if ( pi1->size != pi2->size ) + return 0; + for ( i = 0; i < pi1->size; i++ ) + if ( pi1->pe[i] != pi2->pe[i] ) + return 0; + return 1; +} + +/* px_rand -- generates sort-of random permutation */ +PERM *px_rand(pi) +PERM *pi; +{ + int i, j, k; + + if ( ! pi ) + error(E_NULL,"px_rand"); + + for ( i = 0; i < 3*pi->size; i++ ) + { + j = (rand() >> 8) % pi->size; + k = (rand() >> 8) % pi->size; + px_transp(pi,j,k); + } + + return pi; +} + +#define SAVE_FILE "asx5213a.mat" +#define MATLAB_NAME "alpha" +char name[81] = MATLAB_NAME; + +int main(argc, argv) +int argc; +char *argv[]; +{ + VEC *x = VNULL, *y = VNULL, *z = VNULL, *u = VNULL, *v = VNULL, + *w = VNULL; + VEC *diag = VNULL, *beta = VNULL; + PERM *pi1 = PNULL, *pi2 = PNULL, *pi3 = PNULL, *pivot = PNULL, + *blocks = PNULL; + MAT *A = MNULL, *Atmp = MNULL, *B = MNULL, *C = MNULL, *D = MNULL, + *Q = MNULL, *Qtmp = MNULL, *U = MNULL; + BAND *bA, *bB, *bC; + Real cond_est, s1, s2, s3; + int i, j, seed; + FILE *fp; + char *cp; + + + mem_info_on(TRUE); + + setbuf(stdout,(char *)NULL); + + seed = 1111; + if ( argc > 2 ) + { + printf("usage: %s [seed]\n",argv[0]); + exit(0); + } + else if ( argc == 2 ) + sscanf(argv[1], "%d", &seed); + + /* set seed for rand() */ + smrand(seed); + + mem_stat_mark(1); + + /* print version information */ + m_version(); + + printf("# grep \"^Error\" the output for a listing of errors\n"); + printf("# Don't panic if you see \"Error\" appearing; \n"); + printf("# Also check the reported size of error\n"); + printf("# This program uses randomly generated problems and therefore\n"); + printf("# may occasionally produce ill-conditioned problems\n"); + printf("# Therefore check the size of the error compared with MACHEPS\n"); + printf("# If the error is within 1000*MACHEPS then don't worry\n"); + printf("# If you get an error of size 0.1 or larger there is \n"); + printf("# probably a bug in the code or the compilation procedure\n\n"); + printf("# seed = %d\n",seed); + + printf("# Check: MACHEPS = %g\n",MACHEPS); + /* allocate, initialise, copy and resize operations */ + /* VEC */ + notice("vector initialise, copy & resize"); + x = v_get(12); + y = v_get(15); + z = v_get(12); + v_rand(x); + v_rand(y); + z = v_copy(x,z); + if ( v_norm2(v_sub(x,z,z)) >= MACHEPS ) + errmesg("VEC copy"); + v_copy(x,y); + x = v_resize(x,10); + y = v_resize(y,10); + if ( v_norm2(v_sub(x,y,z)) >= MACHEPS ) + errmesg("VEC copy/resize"); + x = v_resize(x,15); + y = v_resize(y,15); + if ( v_norm2(v_sub(x,y,z)) >= MACHEPS ) + errmesg("VEC resize"); + + /* MAT */ + notice("matrix initialise, copy & resize"); + A = m_get(8,5); + B = m_get(3,9); + C = m_get(8,5); + m_rand(A); + m_rand(B); + C = m_copy(A,C); + if ( m_norm_inf(m_sub(A,C,C)) >= MACHEPS ) + errmesg("MAT copy"); + m_copy(A,B); + A = m_resize(A,3,5); + B = m_resize(B,3,5); + if ( m_norm_inf(m_sub(A,B,C)) >= MACHEPS ) + errmesg("MAT copy/resize"); + A = m_resize(A,10,10); + B = m_resize(B,10,10); + if ( m_norm_inf(m_sub(A,B,C)) >= MACHEPS ) + errmesg("MAT resize"); + + MEMCHK(); + + /* PERM */ + notice("permutation initialise, inverting & permuting vectors"); + pi1 = px_get(15); + pi2 = px_get(12); + px_rand(pi1); + v_rand(x); + px_vec(pi1,x,z); + y = v_resize(y,x->dim); + pxinv_vec(pi1,z,y); + if ( v_norm2(v_sub(x,y,z)) >= MACHEPS ) + errmesg("PERMute vector"); + pi2 = px_inv(pi1,pi2); + pi3 = px_mlt(pi1,pi2,PNULL); + for ( i = 0; i < pi3->size; i++ ) + if ( pi3->pe[i] != i ) + errmesg("PERM inverse/multiply"); + + /* testing m_catch() etc */ + notice("error handling routines"); + m_catch(E_NULL, + catchall(v_add(VNULL,VNULL,VNULL); + errmesg("tracecatch() failure"), + printf("# tracecatch() caught error\n"); + error(E_NULL,"main")); + errmesg("m_catch() failure"), + printf("# m_catch() caught E_NULL error\n")); + + /* testing attaching a new error list (error list 2) */ + + notice("attaching error lists"); + printf("# IT IS NOT A REAL WARNING ... \n"); + err_list_attach(2,MAX_TEST_ERR,test_err_list,TRUE); + if (!err_is_list_attached(2)) + errmesg("attaching the error list 2"); + ev_err(__FILE__,1,__LINE__,"main",2); + err_list_free(2); + if (err_is_list_attached(2)) + errmesg("detaching the error list 2"); + + /* testing inner products and v_mltadd() etc */ + notice("inner products and linear combinations"); + u = v_get(x->dim); + v_rand(u); + v_rand(x); + v_resize(y,x->dim); + v_rand(y); + v_mltadd(y,x,-in_prod(x,y)/in_prod(x,x),z); + if ( fabs(in_prod(x,z)) >= MACHEPS*x->dim ) + errmesg("v_mltadd()/in_prod()"); + s1 = -in_prod(x,y)/(v_norm2(x)*v_norm2(x)); + sv_mlt(s1,x,u); + v_add(y,u,u); + if ( v_norm2(v_sub(u,z,u)) >= MACHEPS*x->dim ) + errmesg("sv_mlt()/v_norm2()"); + +#ifdef ANSI_C + v_linlist(u,x,s1,y,1.0,VNULL); + if ( v_norm2(v_sub(u,z,u)) >= MACHEPS*x->dim ) + errmesg("v_linlist()"); +#endif +#ifdef VARARGS + v_linlist(u,x,s1,y,1.0,VNULL); + if ( v_norm2(v_sub(u,z,u)) >= MACHEPS*x->dim ) + errmesg("v_linlist()"); +#endif + + + MEMCHK(); + + /* vector norms */ + notice("vector norms"); + x = v_resize(x,12); + v_rand(x); + for ( i = 0; i < x->dim; i++ ) + if ( v_entry(x,i) >= 0.5 ) + v_set_val(x,i,1.0); + else + v_set_val(x,i,-1.0); + s1 = v_norm1(x); + s2 = v_norm2(x); + s3 = v_norm_inf(x); + if ( fabs(s1 - x->dim) >= MACHEPS*x->dim || + fabs(s2 - sqrt((Real)(x->dim))) >= MACHEPS*x->dim || + fabs(s3 - 1.0) >= MACHEPS ) + errmesg("v_norm1/2/_inf()"); + + /* test matrix multiply etc */ + notice("matrix multiply and invert"); + A = m_resize(A,10,10); + B = m_resize(B,10,10); + m_rand(A); + m_inverse(A,B); + m_mlt(A,B,C); + for ( i = 0; i < C->m; i++ ) + m_set_val(C,i,i,m_entry(C,i,i)-1.0); + if ( m_norm_inf(C) >= MACHEPS*m_norm_inf(A)*m_norm_inf(B)*5 ) + errmesg("m_inverse()/m_mlt()"); + + MEMCHK(); + + /* ... and transposes */ + notice("transposes and transpose-multiplies"); + m_transp(A,A); /* can do square matrices in situ */ + mtrm_mlt(A,B,C); + for ( i = 0; i < C->m; i++ ) + m_set_val(C,i,i,m_entry(C,i,i)-1.0); + if ( m_norm_inf(C) >= MACHEPS*m_norm_inf(A)*m_norm_inf(B)*5 ) + errmesg("m_transp()/mtrm_mlt()"); + m_transp(A,A); + m_transp(B,B); + mmtr_mlt(A,B,C); + for ( i = 0; i < C->m; i++ ) + m_set_val(C,i,i,m_entry(C,i,i)-1.0); + if ( m_norm_inf(C) >= MACHEPS*m_norm_inf(A)*m_norm_inf(B)*5 ) + errmesg("m_transp()/mmtr_mlt()"); + sm_mlt(3.71,B,B); + mmtr_mlt(A,B,C); + for ( i = 0; i < C->m; i++ ) + m_set_val(C,i,i,m_entry(C,i,i)-3.71); + if ( m_norm_inf(C) >= MACHEPS*m_norm_inf(A)*m_norm_inf(B)*5 ) + errmesg("sm_mlt()/mmtr_mlt()"); + m_transp(B,B); + sm_mlt(1.0/3.71,B,B); + + MEMCHK(); + + /* ... and matrix-vector multiplies */ + notice("matrix-vector multiplies"); + x = v_resize(x,A->n); + y = v_resize(y,A->m); + z = v_resize(z,A->m); + u = v_resize(u,A->n); + v_rand(x); + v_rand(y); + mv_mlt(A,x,z); + s1 = in_prod(y,z); + vm_mlt(A,y,u); + s2 = in_prod(u,x); + if ( fabs(s1 - s2) >= (MACHEPS*x->dim)*x->dim ) + errmesg("mv_mlt()/vm_mlt()"); + mv_mlt(B,z,u); + if ( v_norm2(v_sub(u,x,u)) >= MACHEPS*m_norm_inf(A)*m_norm_inf(B)*5 ) + errmesg("mv_mlt()/m_inverse()"); + + MEMCHK(); + + /* get/set row/col */ + notice("getting and setting rows and cols"); + x = v_resize(x,A->n); + y = v_resize(y,B->m); + x = get_row(A,3,x); + y = get_col(B,3,y); + if ( fabs(in_prod(x,y) - 1.0) >= MACHEPS*m_norm_inf(A)*m_norm_inf(B)*5 ) + errmesg("get_row()/get_col()"); + sv_mlt(-1.0,x,x); + sv_mlt(-1.0,y,y); + set_row(A,3,x); + set_col(B,3,y); + m_mlt(A,B,C); + for ( i = 0; i < C->m; i++ ) + m_set_val(C,i,i,m_entry(C,i,i)-1.0); + if ( m_norm_inf(C) >= MACHEPS*m_norm_inf(A)*m_norm_inf(B)*5 ) + errmesg("set_row()/set_col()"); + + MEMCHK(); + + /* matrix norms */ + notice("matrix norms"); + A = m_resize(A,11,15); + m_rand(A); + s1 = m_norm_inf(A); + B = m_transp(A,B); + s2 = m_norm1(B); + if ( fabs(s1 - s2) >= MACHEPS*A->m ) + errmesg("m_norm1()/m_norm_inf()"); + C = mtrm_mlt(A,A,C); + s1 = 0.0; + for ( i = 0; i < C->m && i < C->n; i++ ) + s1 += m_entry(C,i,i); + if ( fabs(sqrt(s1) - m_norm_frob(A)) >= MACHEPS*A->m*A->n ) + errmesg("m_norm_frob"); + + MEMCHK(); + + /* permuting rows and columns */ + notice("permuting rows & cols"); + A = m_resize(A,11,15); + B = m_resize(B,11,15); + pi1 = px_resize(pi1,A->m); + px_rand(pi1); + x = v_resize(x,A->n); + y = mv_mlt(A,x,y); + px_rows(pi1,A,B); + px_vec(pi1,y,z); + mv_mlt(B,x,u); + if ( v_norm2(v_sub(z,u,u)) >= MACHEPS*A->m ) + errmesg("px_rows()"); + pi1 = px_resize(pi1,A->n); + px_rand(pi1); + px_cols(pi1,A,B); + pxinv_vec(pi1,x,z); + mv_mlt(B,z,u); + if ( v_norm2(v_sub(y,u,u)) >= MACHEPS*A->n ) + errmesg("px_cols()"); + + MEMCHK(); + + /* MATLAB save/load */ + notice("MATLAB save/load"); + A = m_resize(A,12,11); + if ( (fp=fopen(SAVE_FILE,"w")) == (FILE *)NULL ) + printf("Cannot perform MATLAB save/load test\n"); + else + { + m_rand(A); + m_save(fp, A, name); + fclose(fp); + if ( (fp=fopen(SAVE_FILE,"r")) == (FILE *)NULL ) + printf("Cannot open save file \"%s\"\n",SAVE_FILE); + else + { + M_FREE(B); + B = m_load(fp,&cp); + if ( strcmp(name,cp) || m_norm1(m_sub(A,B,B)) >= MACHEPS*A->m ) + errmesg("mload()/m_save()"); + } + } + + MEMCHK(); + + /* Now, onto matrix factorisations */ + A = m_resize(A,10,10); + B = m_resize(B,A->m,A->n); + m_copy(A,B); + x = v_resize(x,A->n); + y = v_resize(y,A->m); + z = v_resize(z,A->n); + u = v_resize(u,A->m); + v_rand(x); + mv_mlt(B,x,y); + z = v_copy(x,z); + + notice("LU factor/solve"); + pivot = px_get(A->m); + LUfactor(A,pivot); + tracecatch(LUsolve(A,pivot,y,x),"main"); + tracecatch(cond_est = LUcondest(A,pivot),"main"); + printf("# cond(A) approx= %g\n", cond_est); + if ( v_norm2(v_sub(x,z,u)) >= MACHEPS*v_norm2(x)*cond_est) + { + errmesg("LUfactor()/LUsolve()"); + printf("# LU solution error = %g [cf MACHEPS = %g]\n", + v_norm2(v_sub(x,z,u)), MACHEPS); + } + + v_copy(y,x); + tracecatch(LUsolve(A,pivot,x,x),"main"); + tracecatch(cond_est = LUcondest(A,pivot),"main"); + if ( v_norm2(v_sub(x,z,u)) >= MACHEPS*v_norm2(x)*cond_est) + { + errmesg("LUfactor()/LUsolve()"); + printf("# LU solution error = %g [cf MACHEPS = %g]\n", + v_norm2(v_sub(x,z,u)), MACHEPS); + } + + vm_mlt(B,z,y); + v_copy(y,x); + tracecatch(LUTsolve(A,pivot,x,x),"main"); + if ( v_norm2(v_sub(x,z,u)) >= MACHEPS*v_norm2(x)*cond_est) + { + errmesg("LUfactor()/LUTsolve()"); + printf("# LU solution error = %g [cf MACHEPS = %g]\n", + v_norm2(v_sub(x,z,u)), MACHEPS); + } + + MEMCHK(); + + /* QR factorisation */ + m_copy(B,A); + mv_mlt(B,z,y); + notice("QR factor/solve:"); + diag = v_get(A->m); + beta = v_get(A->m); + QRfactor(A,diag); + QRsolve(A,diag,y,x); + if ( v_norm2(v_sub(x,z,u)) >= MACHEPS*v_norm2(x)*cond_est ) + { + errmesg("QRfactor()/QRsolve()"); + printf("# QR solution error = %g [cf MACHEPS = %g]\n", + v_norm2(v_sub(x,z,u)), MACHEPS); + } + Q = m_get(A->m,A->m); + makeQ(A,diag,Q); + makeR(A,A); + m_mlt(Q,A,C); + m_sub(B,C,C); + if ( m_norm1(C) >= MACHEPS*m_norm1(Q)*m_norm1(B) ) + { + errmesg("QRfactor()/makeQ()/makeR()"); + printf("# QR reconstruction error = %g [cf MACHEPS = %g]\n", + m_norm1(C), MACHEPS); + } + + MEMCHK(); + + /* now try with a non-square matrix */ + A = m_resize(A,15,7); + m_rand(A); + B = m_copy(A,B); + diag = v_resize(diag,A->n); + beta = v_resize(beta,A->n); + x = v_resize(x,A->n); + y = v_resize(y,A->m); + v_rand(y); + QRfactor(A,diag); + x = QRsolve(A,diag,y,x); + /* z is the residual vector */ + mv_mlt(B,x,z); v_sub(z,y,z); + /* check B^T.z = 0 */ + vm_mlt(B,z,u); + if ( v_norm2(u) >= MACHEPS*m_norm1(B)*v_norm2(y) ) + { + errmesg("QRfactor()/QRsolve()"); + printf("# QR solution error = %g [cf MACHEPS = %g]\n", + v_norm2(u), MACHEPS); + } + Q = m_resize(Q,A->m,A->m); + makeQ(A,diag,Q); + makeR(A,A); + m_mlt(Q,A,C); + m_sub(B,C,C); + if ( m_norm1(C) >= MACHEPS*m_norm1(Q)*m_norm1(B) ) + { + errmesg("QRfactor()/makeQ()/makeR()"); + printf("# QR reconstruction error = %g [cf MACHEPS = %g]\n", + m_norm1(C), MACHEPS); + } + D = m_get(A->m,Q->m); + mtrm_mlt(Q,Q,D); + for ( i = 0; i < D->m; i++ ) + m_set_val(D,i,i,m_entry(D,i,i)-1.0); + if ( m_norm1(D) >= MACHEPS*m_norm1(Q)*m_norm_inf(Q) ) + { + errmesg("QRfactor()/makeQ()/makeR()"); + printf("# QR orthogonality error = %g [cf MACHEPS = %g]\n", + m_norm1(D), MACHEPS); + } + + MEMCHK(); + + /* QRCP factorisation */ + m_copy(B,A); + notice("QR factor/solve with column pivoting"); + pivot = px_resize(pivot,A->n); + QRCPfactor(A,diag,pivot); + z = v_resize(z,A->n); + QRCPsolve(A,diag,pivot,y,z); + /* pxinv_vec(pivot,z,x); */ + /* now compute residual (z) vector */ + mv_mlt(B,x,z); v_sub(z,y,z); + /* check B^T.z = 0 */ + vm_mlt(B,z,u); + if ( v_norm2(u) >= MACHEPS*m_norm1(B)*v_norm2(y) ) + { + errmesg("QRCPfactor()/QRsolve()"); + printf("# QR solution error = %g [cf MACHEPS = %g]\n", + v_norm2(u), MACHEPS); + } + + Q = m_resize(Q,A->m,A->m); + makeQ(A,diag,Q); + makeR(A,A); + m_mlt(Q,A,C); + M_FREE(D); + D = m_get(B->m,B->n); + px_cols(pivot,C,D); + m_sub(B,D,D); + if ( m_norm1(D) >= MACHEPS*m_norm1(Q)*m_norm1(B) ) + { + errmesg("QRCPfactor()/makeQ()/makeR()"); + printf("# QR reconstruction error = %g [cf MACHEPS = %g]\n", + m_norm1(D), MACHEPS); + } + + MEMCHK(); + + /* Cholesky and LDL^T factorisation */ + /* Use these for normal equations approach */ + notice("Cholesky factor/solve"); + mtrm_mlt(B,B,A); + CHfactor(A); + u = v_resize(u,B->n); + vm_mlt(B,y,u); + z = v_resize(z,B->n); + CHsolve(A,u,z); + v_sub(x,z,z); + if ( v_norm2(z) >= MACHEPS*v_norm2(x)*100 ) + { + errmesg("CHfactor()/CHsolve()"); + printf("# Cholesky solution error = %g [cf MACHEPS = %g]\n", + v_norm2(z), MACHEPS); + } + /* modified Cholesky factorisation should be identical with Cholesky + factorisation provided the matrix is "sufficiently positive definite */ + mtrm_mlt(B,B,C); + MCHfactor(C,MACHEPS); + m_sub(A,C,C); + if ( m_norm1(C) >= MACHEPS*m_norm1(A) ) + { + errmesg("MCHfactor()"); + printf("# Modified Cholesky error = %g [cf MACHEPS = %g]\n", + m_norm1(C), MACHEPS); + } + /* now test the LDL^T factorisation -- using a negative def. matrix */ + mtrm_mlt(B,B,A); + sm_mlt(-1.0,A,A); + m_copy(A,C); + LDLfactor(A); + LDLsolve(A,u,z); + w = v_get(A->m); + mv_mlt(C,z,w); + v_sub(w,u,w); + if ( v_norm2(w) >= MACHEPS*v_norm2(u)*m_norm1(C) ) + { + errmesg("LDLfactor()/LDLsolve()"); + printf("# LDL^T residual = %g [cf MACHEPS = %g]\n", + v_norm2(w), MACHEPS); + } + v_add(x,z,z); + if ( v_norm2(z) >= MACHEPS*v_norm2(x)*100 ) + { + errmesg("LDLfactor()/LDLsolve()"); + printf("# LDL^T solution error = %g [cf MACHEPS = %g]\n", + v_norm2(z), MACHEPS); + } + + MEMCHK(); + + /* and now the Bunch-Kaufman-Parlett method */ + /* set up D to be an indefinite diagonal matrix */ + notice("Bunch-Kaufman-Parlett factor/solve"); + + D = m_resize(D,B->m,B->m); + m_zero(D); + w = v_resize(w,B->m); + v_rand(w); + for ( i = 0; i < w->dim; i++ ) + if ( v_entry(w,i) >= 0.5 ) + m_set_val(D,i,i,1.0); + else + m_set_val(D,i,i,-1.0); + /* set A <- B^T.D.B */ + C = m_resize(C,B->n,B->n); + C = mtrm_mlt(B,D,C); + A = m_mlt(C,B,A); + C = m_resize(C,B->n,B->n); + C = m_copy(A,C); + /* ... and use BKPfactor() */ + blocks = px_get(A->m); + pivot = px_resize(pivot,A->m); + x = v_resize(x,A->m); + y = v_resize(y,A->m); + z = v_resize(z,A->m); + v_rand(x); + mv_mlt(A,x,y); + BKPfactor(A,pivot,blocks); + printf("# BKP pivot =\n"); px_output(pivot); + printf("# BKP blocks =\n"); px_output(blocks); + BKPsolve(A,pivot,blocks,y,z); + /* compute & check residual */ + mv_mlt(C,z,w); + v_sub(w,y,w); + if ( v_norm2(w) >= MACHEPS*m_norm1(C)*v_norm2(z) ) + { + errmesg("BKPfactor()/BKPsolve()"); + printf("# BKP residual size = %g [cf MACHEPS = %g]\n", + v_norm2(w), MACHEPS); + } + + /* check update routines */ + /* check LDLupdate() first */ + notice("update L.D.L^T routine"); + A = mtrm_mlt(B,B,A); + m_resize(C,A->m,A->n); + C = m_copy(A,C); + LDLfactor(A); + s1 = 3.7; + w = v_resize(w,A->m); + v_rand(w); + for ( i = 0; i < C->m; i++ ) + for ( j = 0; j < C->n; j++ ) + m_set_val(C,i,j,m_entry(C,i,j)+s1*v_entry(w,i)*v_entry(w,j)); + LDLfactor(C); + LDLupdate(A,w,s1); + /* zero out strictly upper triangular parts of A and C */ + for ( i = 0; i < A->m; i++ ) + for ( j = i+1; j < A->n; j++ ) + { + m_set_val(A,i,j,0.0); + m_set_val(C,i,j,0.0); + } + if ( m_norm1(m_sub(A,C,C)) >= sqrt(MACHEPS)*m_norm1(A) ) + { + errmesg("LDLupdate()"); + printf("# LDL update matrix error = %g [cf MACHEPS = %g]\n", + m_norm1(C), MACHEPS); + } + + + /* BAND MATRICES */ + +#define COL 40 +#define UDIAG 5 +#define LDIAG 2 + + smrand(101); + bA = bd_get(LDIAG,UDIAG,COL); + bB = bd_get(LDIAG,UDIAG,COL); + bC = bd_get(LDIAG,UDIAG,COL); + A = m_resize(A,COL,COL); + B = m_resize(B,COL,COL); + pivot = px_resize(pivot,COL); + x = v_resize(x,COL); + w = v_resize(w,COL); + z = v_resize(z,COL); + + m_rand(A); + /* generate band matrix */ + mat2band(A,LDIAG,UDIAG,bA); + band2mat(bA,A); /* now A is banded */ + bB = bd_copy(bA,bB); + + v_rand(x); + mv_mlt(A,x,w); + z = v_copy(w,z); + + notice("band LU factorization"); + bdLUfactor(bA,pivot); + + /* pivot will be changed */ + bdLUsolve(bA,pivot,z,z); + v_sub(x,z,z); + if (v_norm2(z) > v_norm2(x)*sqrt(MACHEPS)) { + errmesg("incorrect solution (band LU factorization)"); + printf(" ||exact sol. - computed sol.|| = %g [MACHEPS = %g]\n", + v_norm2(z),MACHEPS); + } + + /* solve transpose system */ + + notice("band LU factorization for transpose system"); + m_transp(A,B); + mv_mlt(B,x,w); + + bd_copy(bB,bA); + bd_transp(bA,bA); + /* transposition in situ */ + bd_transp(bA,bB); + bd_transp(bB,bB); + + bdLUfactor(bB,pivot); + + bdLUsolve(bB,pivot,w,z); + v_sub(x,z,z); + if (v_norm2(z) > v_norm2(x)*sqrt(MACHEPS)) { + errmesg("incorrect solution (band transposed LU factorization)"); + printf(" ||exact sol. - computed sol.|| = %g [MACHEPS = %g]\n", + v_norm2(z),MACHEPS); + } + + + /* Cholesky factorization */ + + notice("band Choleski LDL' factorization"); + m_add(A,B,A); /* symmetric matrix */ + for (i=0; i < COL; i++) /* positive definite */ + A->me[i][i] += 2*LDIAG; + + mat2band(A,LDIAG,LDIAG,bA); + band2mat(bA,A); /* corresponding matrix A */ + + v_rand(x); + mv_mlt(A,x,w); + z = v_copy(w,z); + + bdLDLfactor(bA); + + z = bdLDLsolve(bA,z,z); + v_sub(x,z,z); + if (v_norm2(z) > v_norm2(x)*sqrt(MACHEPS)) { + errmesg("incorrect solution (band LDL' factorization)"); + printf(" ||exact sol. - computed sol.|| = %g [MACHEPS = %g]\n", + v_norm2(z),MACHEPS); + } + + /* new bandwidths */ + m_rand(A); + bA = bd_resize(bA,UDIAG,LDIAG,COL); + bB = bd_resize(bB,UDIAG,LDIAG,COL); + mat2band(A,UDIAG,LDIAG,bA); + band2mat(bA,A); + bd_copy(bA,bB); + + mv_mlt(A,x,w); + + notice("band LU factorization (resized)"); + bdLUfactor(bA,pivot); + + /* pivot will be changed */ + bdLUsolve(bA,pivot,w,z); + v_sub(x,z,z); + if (v_norm2(z) > v_norm2(x)*sqrt(MACHEPS)) { + errmesg("incorrect solution (band LU factorization)"); + printf(" ||exact sol. - computed sol.|| = %g [MACHEPS = %g]\n", + v_norm2(z),MACHEPS); + } + + /* testing transposition */ + + notice("band matrix transposition"); + m_zero(bA->mat); + bd_copy(bB,bA); + m_zero(bB->mat); + bd_copy(bA,bB); + + bd_transp(bB,bB); + bd_transp(bB,bB); + + m_zero(bC->mat); + bd_copy(bB,bC); + + m_sub(bA->mat,bC->mat,bC->mat); + if (m_norm_inf(bC->mat) > MACHEPS*bC->mat->n) { + errmesg("band transposition"); + printf(" difference ||A - (A')'|| = %g\n",m_norm_inf(bC->mat)); + } + + bd_free(bA); + bd_free(bB); + bd_free(bC); + + + MEMCHK(); + + /* now check QRupdate() routine */ + notice("update QR routine"); + + B = m_resize(B,15,7); + A = m_resize(A,B->m,B->n); + m_copy(B,A); + diag = v_resize(diag,A->n); + beta = v_resize(beta,A->n); + QRfactor(A,diag); + Q = m_resize(Q,A->m,A->m); + makeQ(A,diag,Q); + makeR(A,A); + m_resize(C,A->m,A->n); + w = v_resize(w,A->m); + v = v_resize(v,A->n); + u = v_resize(u,A->m); + v_rand(w); + v_rand(v); + vm_mlt(Q,w,u); + QRupdate(Q,A,u,v); + m_mlt(Q,A,C); + for ( i = 0; i < B->m; i++ ) + for ( j = 0; j < B->n; j++ ) + m_set_val(B,i,j,m_entry(B,i,j)+v_entry(w,i)*v_entry(v,j)); + m_sub(B,C,C); + if ( m_norm1(C) >= MACHEPS*m_norm1(A)*m_norm1(Q)*2 ) + { + errmesg("QRupdate()"); + printf("# Reconstruction error in QR update = %g [cf MACHEPS = %g]\n", + m_norm1(C), MACHEPS); + } + m_resize(D,Q->m,Q->n); + mtrm_mlt(Q,Q,D); + for ( i = 0; i < D->m; i++ ) + m_set_val(D,i,i,m_entry(D,i,i)-1.0); + if ( m_norm1(D) >= 10*MACHEPS*m_norm1(Q)*m_norm_inf(Q) ) + { + errmesg("QRupdate()"); + printf("# QR update orthogonality error = %g [cf MACHEPS = %g]\n", + m_norm1(D), MACHEPS); + } + + /* Now check eigenvalue/SVD routines */ + notice("eigenvalue and SVD routines"); + A = m_resize(A,11,11); + B = m_resize(B,A->m,A->n); + C = m_resize(C,A->m,A->n); + D = m_resize(D,A->m,A->n); + Q = m_resize(Q,A->m,A->n); + + m_rand(A); + /* A <- A + A^T for symmetric case */ + m_add(A,m_transp(A,C),A); + u = v_resize(u,A->m); + u = symmeig(A,Q,u); + m_zero(B); + for ( i = 0; i < B->m; i++ ) + m_set_val(B,i,i,v_entry(u,i)); + m_mlt(Q,B,C); + mmtr_mlt(C,Q,D); + m_sub(A,D,D); + if ( m_norm1(D) >= MACHEPS*m_norm1(Q)*m_norm_inf(Q)*v_norm_inf(u)*3 ) + { + errmesg("symmeig()"); + printf("# Reconstruction error = %g [cf MACHEPS = %g]\n", + m_norm1(D), MACHEPS); + } + mtrm_mlt(Q,Q,D); + for ( i = 0; i < D->m; i++ ) + m_set_val(D,i,i,m_entry(D,i,i)-1.0); + if ( m_norm1(D) >= MACHEPS*m_norm1(Q)*m_norm_inf(Q)*3 ) + { + errmesg("symmeig()"); + printf("# symmeig() orthogonality error = %g [cf MACHEPS = %g]\n", + m_norm1(D), MACHEPS); + } + + MEMCHK(); + + /* now test (real) Schur decomposition */ + /* m_copy(A,B); */ + M_FREE(A); + A = m_get(11,11); + m_rand(A); + B = m_copy(A,B); + MEMCHK(); + + B = schur(B,Q); + MEMCHK(); + + m_mlt(Q,B,C); + mmtr_mlt(C,Q,D); + MEMCHK(); + m_sub(A,D,D); + if ( m_norm1(D) >= MACHEPS*m_norm1(Q)*m_norm_inf(Q)*m_norm1(B)*5 ) + { + errmesg("schur()"); + printf("# Schur reconstruction error = %g [cf MACHEPS = %g]\n", + m_norm1(D), MACHEPS); + } + + /* orthogonality check */ + mmtr_mlt(Q,Q,D); + for ( i = 0; i < D->m; i++ ) + m_set_val(D,i,i,m_entry(D,i,i)-1.0); + if ( m_norm1(D) >= MACHEPS*m_norm1(Q)*m_norm_inf(Q)*10 ) + { + errmesg("schur()"); + printf("# Schur orthogonality error = %g [cf MACHEPS = %g]\n", + m_norm1(D), MACHEPS); + } + + MEMCHK(); + + /* check for termination */ + Atmp = m_get(2,2); + Qtmp = m_get(2,2); + /* this is a 2 x 2 matrix with real eigenvalues */ + Atmp->me[0][0] = 1; + Atmp->me[1][1] = 1; + Atmp->me[0][1] = 4; + Atmp->me[1][0] = 1; + schur(Atmp,Qtmp); + + MEMCHK(); + + /* now test SVD */ + A = m_resize(A,11,7); + m_rand(A); + U = m_get(A->n,A->n); + Q = m_resize(Q,A->m,A->m); + u = v_resize(u,max(A->m,A->n)); + svd(A,Q,U,u); + /* check reconstruction of A */ + D = m_resize(D,A->m,A->n); + C = m_resize(C,A->m,A->n); + m_zero(D); + for ( i = 0; i < min(A->m,A->n); i++ ) + m_set_val(D,i,i,v_entry(u,i)); + mtrm_mlt(Q,D,C); + m_mlt(C,U,D); + m_sub(A,D,D); + if ( m_norm1(D) >= MACHEPS*m_norm1(U)*m_norm_inf(Q)*m_norm1(A) ) + { + errmesg("svd()"); + printf("# SVD reconstruction error = %g [cf MACHEPS = %g]\n", + m_norm1(D), MACHEPS); + } + /* check orthogonality of Q and U */ + D = m_resize(D,Q->n,Q->n); + mtrm_mlt(Q,Q,D); + for ( i = 0; i < D->m; i++ ) + m_set_val(D,i,i,m_entry(D,i,i)-1.0); + if ( m_norm1(D) >= MACHEPS*m_norm1(Q)*m_norm_inf(Q)*5 ) + { + errmesg("svd()"); + printf("# SVD orthognality error (Q) = %g [cf MACHEPS = %g\n", + m_norm1(D), MACHEPS); + } + D = m_resize(D,U->n,U->n); + mtrm_mlt(U,U,D); + for ( i = 0; i < D->m; i++ ) + m_set_val(D,i,i,m_entry(D,i,i)-1.0); + if ( m_norm1(D) >= MACHEPS*m_norm1(U)*m_norm_inf(U)*5 ) + { + errmesg("svd()"); + printf("# SVD orthognality error (U) = %g [cf MACHEPS = %g\n", + m_norm1(D), MACHEPS); + } + for ( i = 0; i < u->dim; i++ ) + if ( v_entry(u,i) < 0 || (i < u->dim-1 && + v_entry(u,i+1) > v_entry(u,i)) ) + break; + if ( i < u->dim ) + { + errmesg("svd()"); + printf("# SVD sorting error\n"); + } + + + /* test of long vectors */ + notice("Long vectors"); + x = v_resize(x,100000); + y = v_resize(y,100000); + z = v_resize(z,100000); + v_rand(x); + v_rand(y); + v_mltadd(x,y,3.0,z); + sv_mlt(1.0/3.0,z,z); + v_mltadd(z,x,-1.0/3.0,z); + v_sub(z,y,x); + if (v_norm2(x) >= MACHEPS*(x->dim)) { + errmesg("long vectors"); + printf(" norm = %g\n",v_norm2(x)); + } + + mem_stat_free(1); + + MEMCHK(); + + /************************************************** + VEC *x, *y, *z, *u, *v, *w; + VEC *diag, *beta; + PERM *pi1, *pi2, *pi3, *pivot, *blocks; + MAT *A, *B, *C, *D, *Q, *U; + **************************************************/ + V_FREE(x); V_FREE(y); V_FREE(z); + V_FREE(u); V_FREE(v); V_FREE(w); + V_FREE(diag); V_FREE(beta); + PX_FREE(pi1); PX_FREE(pi2); PX_FREE(pi3); + PX_FREE(pivot); PX_FREE(blocks); + M_FREE(A); M_FREE(B); M_FREE(C); + M_FREE(D); M_FREE(Q); M_FREE(U); + M_FREE(Atmp); M_FREE(Qtmp); + + MEMCHK(); + printf("# Finished torture test\n"); + mem_info(); + + return 0; +} + diff --git a/meschach/tutadv.c b/meschach/tutadv.c new file mode 100644 index 0000000..ac40d7a --- /dev/null +++ b/meschach/tutadv.c @@ -0,0 +1,192 @@ + +/* routines from the section 8 of tutorial.txt */ + +#include "matrix.h" + +#define M3D_LIST 3 /* list number */ +#define TYPE_MAT3D 0 /* the number of a type */ + +/* type for 3 dimensional matrices */ +typedef struct { + int l,m,n; /* actual dimensions */ + int max_l, max_m, max_n; /* maximal dimensions */ + Real ***me; /* pointer to matrix elements */ + /* we do not consider segmented memory */ + Real *base, **me2d; /* me and me2d are additional pointers + to base */ +} MAT3D; + + +/* function for creating a variable of MAT3D type */ + +MAT3D *m3d_get(l,m,n) +int l,m,n; +{ + MAT3D *mat; + int i,j,k; + + /* check if arguments are positive */ + if (l <= 0 || m <= 0 || n <= 0) + error(E_NEG,"m3d_get"); + + /* new structure */ + if ((mat = NEW(MAT3D)) == (MAT3D *)NULL) + error(E_MEM,"m3d_get"); + else if (mem_info_is_on()) { + /* record how many bytes is allocated */ + mem_bytes_list(TYPE_MAT3D,0,sizeof(MAT3D),M3D_LIST); + /* record a new allocated variable */ + mem_numvar_list(TYPE_MAT3D,1,M3D_LIST); + } + + mat->l = mat->max_l = l; + mat->m = mat->max_m = m; + mat->n = mat->max_n = n; + + /* allocate memory for 3D array */ + if ((mat->base = NEW_A(l*m*n,Real)) == (Real *)NULL) + error(E_MEM,"m3d_get"); + else if (mem_info_is_on()) + mem_bytes_list(TYPE_MAT3D,0,l*m*n*sizeof(Real),M3D_LIST); + + /* allocate memory for 2D pointers */ + if ((mat->me2d = NEW_A(l*m,Real *)) == (Real **)NULL) + error(E_MEM,"m3d_get"); + else if (mem_info_is_on()) + mem_bytes_list(TYPE_MAT3D,0,l*m*sizeof(Real *),M3D_LIST); + + /* allocate memory for 1D pointers */ + if ((mat->me = NEW_A(l,Real **)) == (Real ***)NULL) + error(E_MEM,"m3d_get"); + else if (mem_info_is_on()) + mem_bytes_list(TYPE_MAT3D,0,l*sizeof(Real **),M3D_LIST); + + /* pointers to 2D matrices */ + for (i=0,k=0; i < l; i++) + for (j=0; j < m; j++) + mat->me2d[k++] = &mat->base[(i*m+j)*n]; + + /* pointers to rows */ + for (i=0; i < l; i++) + mat->me[i] = &mat->me2d[i*m]; + + return mat; +} + + +/* deallocate a variable of type MAT3D */ + +int m3d_free(mat) +MAT3D *mat; +{ + /* do not try to deallocate the NULL pointer */ + if (mat == (MAT3D *)NULL) + return -1; + + /* first deallocate base */ + if (mat->base != (Real *)NULL) { + if (mem_info_is_on()) + /* record how many bytes is deallocated */ + mem_bytes_list(TYPE_MAT3D,mat->max_l*mat->max_m*mat->max_n*sizeof(Real), + 0,M3D_LIST); + free((char *)mat->base); + } + + /* deallocate array of 2D pointers */ + if (mat->me2d != (Real **)NULL) { + if (mem_info_is_on()) + /* record how many bytes is deallocated */ + mem_bytes_list(TYPE_MAT3D,mat->max_l*mat->max_m*sizeof(Real *), + 0,M3D_LIST); + free((char *)mat->me2d); + } + + /* deallocate array of 1D pointers */ + if (mat->me != (Real ***)NULL) { + if (mem_info_is_on()) + /* record how many bytes is deallocated */ + mem_bytes_list(TYPE_MAT3D,mat->max_l*sizeof(Real **),0,M3D_LIST); + free((char *)mat->me); + } + + /* deallocate MAT3D structure */ + if (mem_info_is_on()) { + mem_bytes_list(TYPE_MAT3D,sizeof(MAT3D),0,M3D_LIST); + mem_numvar_list(TYPE_MAT3D,-1,M3D_LIST); + } + free((char *)mat); + + return 0; +} + +/*=============================================*/ + +char *m3d_names[] = { + "MAT3D" +}; + + +#define M3D_NUM (sizeof(m3d_names)/sizeof(*m3d_names)) + +int (*m3d_free_funcs[M3D_NUM])() = { + m3d_free +}; + +static MEM_ARRAY m3d_sum[M3D_NUM]; + + +/* test routing for allocating/deallocating static variables */ +void test_stat(k) +int k; +{ + static MAT3D *work; + + if (!work) { + work = m3d_get(10,10,10); + mem_stat_reg_list(&work,TYPE_MAT3D,M3D_LIST); + work->me[9][9][9] = -3.14; + } + + if (k == 9) + printf(" work[9][9][9] = %g\n",work->me[9][9][9]); +} + + +void main() +{ + MAT3D *M; + int i,j,k; + + mem_info_on(TRUE); + /* can be the first command */ + mem_attach_list(M3D_LIST,M3D_NUM,m3d_names,m3d_free_funcs,m3d_sum); + + M = m3d_get(3,4,5); + mem_info_file(stdout,M3D_LIST); + + /* make use of M->me[i][j][k], where i,j,k are non-negative and + i < 3, j < 4, k < 5 */ + + mem_stat_mark(1); + for (i=0; i < 3; i++) + for (j=0; j < 4; j++) + for (k=0; k < 5; k++) { + test_stat(i+j+k); + M->me[i][j][k] = i+j+k; + } + mem_stat_free_list(1,M3D_LIST); + mem_info_file(stdout,M3D_LIST); + + printf(" M[%d][%d][%d] = %g\n",2,3,4,M->me[2][3][4]); + + mem_stat_mark(2); + test_stat(9); + mem_stat_free_list(2,M3D_LIST); + + m3d_free(M); /* if M is not necessary */ + mem_info_file(stdout,M3D_LIST); + +} + + + diff --git a/meschach/tutorial.c b/meschach/tutorial.c new file mode 100644 index 0000000..2c1586c --- /dev/null +++ b/meschach/tutorial.c @@ -0,0 +1,320 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + +/* tutorial.c 10/12/1993 */ + +/* routines from Chapter 1 of Meschach */ + +static char rcsid[] = "$Id: tutorial.c,v 1.1 2001/03/01 17:19:13 rfranke Exp $"; + +#include "matrix.h" + +/* rk4 -- 4th order Runge--Kutta method */ +double rk4(f,t,x,h) +double t, h; +VEC *(*f)(), *x; +{ + static VEC *v1=VNULL, *v2=VNULL, *v3=VNULL, *v4=VNULL; + static VEC *temp=VNULL; + + /* do not work with NULL initial vector */ + if ( x == VNULL ) + error(E_NULL,"rk4"); + + /* ensure that v1, ..., v4, temp are of the correct size */ + v1 = v_resize(v1,x->dim); + v2 = v_resize(v2,x->dim); + v3 = v_resize(v3,x->dim); + v4 = v_resize(v4,x->dim); + temp = v_resize(temp,x->dim); + + /* register workspace variables */ + MEM_STAT_REG(v1,TYPE_VEC); + MEM_STAT_REG(v2,TYPE_VEC); + MEM_STAT_REG(v3,TYPE_VEC); + MEM_STAT_REG(v4,TYPE_VEC); + MEM_STAT_REG(temp,TYPE_VEC); + /* end of memory allocation */ + + (*f)(t,x,v1); /* most compilers allow: "f(t,x,v1);" */ + v_mltadd(x,v1,0.5*h,temp); /* temp = x+.5*h*v1 */ + (*f)(t+0.5*h,temp,v2); + v_mltadd(x,v2,0.5*h,temp); /* temp = x+.5*h*v2 */ + (*f)(t+0.5*h,temp,v3); + v_mltadd(x,v3,h,temp); /* temp = x+h*v3 */ + (*f)(t+h,temp,v4); + + /* now add: v1+2*v2+2*v3+v4 */ + v_copy(v1,temp); /* temp = v1 */ + v_mltadd(temp,v2,2.0,temp); /* temp = v1+2*v2 */ + v_mltadd(temp,v3,2.0,temp); /* temp = v1+2*v2+2*v3 */ + v_add(temp,v4,temp); /* temp = v1+2*v2+2*v3+v4 */ + + /* adjust x */ + v_mltadd(x,temp,h/6.0,x); /* x = x+(h/6)*temp */ + + return t+h; /* return the new time */ +} + + + +/* rk4 -- 4th order Runge-Kutta method */ +/* another variant */ +double rk4_var(f,t,x,h) +double t, h; +VEC *(*f)(), *x; +{ + static VEC *v1, *v2, *v3, *v4, *temp; + + /* do not work with NULL initial vector */ + if ( x == VNULL ) error(E_NULL,"rk4"); + + /* ensure that v1, ..., v4, temp are of the correct size */ + v_resize_vars(x->dim, &v1, &v2, &v3, &v4, &temp, NULL); + + /* register workspace variables */ + mem_stat_reg_vars(0, TYPE_VEC, &v1, &v2, &v3, &v4, &temp, NULL); + /* end of memory allocation */ + + (*f)(t,x,v1); v_mltadd(x,v1,0.5*h,temp); + (*f)(t+0.5*h,temp,v2); v_mltadd(x,v2,0.5*h,temp); + (*f)(t+0.5*h,temp,v3); v_mltadd(x,v3,h,temp); + (*f)(t+h,temp,v4); + + /* now add: temp = v1+2*v2+2*v3+v4 */ + v_linlist(temp, v1, 1.0, v2, 2.0, v3, 2.0, v4, 1.0, VNULL); + /* adjust x */ + v_mltadd(x,temp,h/6.0,x); /* x = x+(h/6)*temp */ + + return t+h; /* return the new time */ +} + + +/* f -- right-hand side of ODE solver */ +VEC *f(t,x,out) +VEC *x, *out; +double t; +{ + if ( x == VNULL || out == VNULL ) + error(E_NULL,"f"); + if ( x->dim != 2 || out->dim != 2 ) + error(E_SIZES,"f"); + + out->ve[0] = x->ve[1]; + out->ve[1] = - x->ve[0]; + + return out; +} + + +void tutor_rk4() +{ + VEC *x; + VEC *f(); + double h, t, t_fin; + double rk4(); + + input("Input initial time: ","%lf",&t); + input("Input final time: ", "%lf",&t_fin); + x = v_get(2); /* this is the size needed by f() */ + prompter("Input initial state:\n"); x = v_input(VNULL); + input("Input step size: ", "%lf",&h); + + printf("# At time %g, the state is\n",t); + v_output(x); + while (t < t_fin) + { + /* you can use t = rk4_var(f,t,x,min(h,t_fin-t)); */ + t = rk4(f,t,x,min(h,t_fin-t)); /* new t is returned */ + printf("# At time %g, the state is\n",t); + v_output(x); + } +} + + + + +#include "matrix2.h" + +void tutor_ls() +{ + MAT *A, *QR; + VEC *b, *x, *diag; + + /* read in A matrix */ + printf("Input A matrix:\n"); + + A = m_input(MNULL); /* A has whatever size is input */ + + if ( A->m < A->n ) + { + printf("Need m >= n to obtain least squares fit\n"); + exit(0); + } + printf("# A =\n"); m_output(A); + diag = v_get(A->m); + /* QR is to be the QR factorisation of A */ + QR = m_copy(A,MNULL); + QRfactor(QR,diag); + /* read in b vector */ + printf("Input b vector:\n"); + b = v_get(A->m); + b = v_input(b); + printf("# b =\n"); v_output(b); + + /* solve for x */ + x = QRsolve(QR,diag,b,VNULL); + printf("Vector of best fit parameters is\n"); + v_output(x); + /* ... and work out norm of errors... */ + printf("||A*x-b|| = %g\n", + v_norm2(v_sub(mv_mlt(A,x,VNULL),b,VNULL))); +} + + +#include +#include "iter.h" + + +#define N 50 +#define VEC2MAT(v,m) vm_move((v),0,(m),0,0,N,N); + +#define PI 3.141592653589793116 +#define index(i,j) (N*((i)-1)+(j)-1) + +/* right hand side function (for generating b) */ +double f1(x,y) +double x,y; +{ + /* return 2.0*PI*PI*sin(PI*x)*sin(PI*y); */ + return exp(x*y); +} + +/* discrete laplacian */ +SPMAT *laplacian(A) +SPMAT *A; +{ + Real h; + int i,j; + + if (!A) + A = sp_get(N*N,N*N,5); + + for ( i = 1; i <= N; i++ ) + for ( j = 1; j <= N; j++ ) + { + if ( i < N ) + sp_set_val(A,index(i,j),index(i+1,j),-1.0); + if ( i > 1 ) + sp_set_val(A,index(i,j),index(i-1,j),-1.0); + if ( j < N ) + sp_set_val(A,index(i,j),index(i,j+1),-1.0); + if ( j > 1 ) + sp_set_val(A,index(i,j),index(i,j-1),-1.0); + sp_set_val(A,index(i,j),index(i,j),4.0); + } + return A; +} + +/* generating right hand side */ +VEC *rhs_lap(b) +VEC *b; +{ + Real h,h2,x,y; + int i,j; + + if (!b) + b = v_get(N*N); + + h = 1.0/(N+1); /* for a unit square */ + h2 = h*h; + x = 0.0; + for ( i = 1; i <= N; i++ ) { + x += h; + y = 0.0; + for ( j = 1; j <= N; j++ ) { + y += h; + b->ve[index(i,j)] = h2*f1(x,y); + } + } + return b; +} + +void tut_lap() +{ + SPMAT *A, *LLT; + VEC *b, *out, *x; + MAT *B; + int num_steps; + FILE *fp; + + A = sp_get(N*N,N*N,5); + b = v_get(N*N); + + laplacian(A); + LLT = sp_copy(A); + spICHfactor(LLT); + + out = v_get(A->m); + x = v_get(A->m); + + rhs_lap(b); /* new rhs */ + iter_spcg(A,LLT,b,1e-6,out,1000,&num_steps); + printf("Number of iterations = %d\n",num_steps); + + /* save b as a MATLAB matrix */ + + fp = fopen("laplace.mat","w"); /* b will be saved in laplace.mat */ + if (fp == NULL) { + printf("Cannot open %s\n","laplace.mat"); + exit(1); + } + + /* b must be transformed to a matrix */ + + B = m_get(N,N); + VEC2MAT(out,B); + m_save(fp,B,"sol"); /* sol is an internal name in MATLAB */ + +} + + +void main() +{ + int i; + + input("Choose the problem (1=Runge-Kutta, 2=least squares,3=laplace): ", + "%d",&i); + switch (i) { + case 1: tutor_rk4(); break; + case 2: tutor_ls(); break; + case 3: tut_lap(); break; + default: + printf(" Wrong value of i (only 1, 2 or 3)\n\n"); + break; + } + +} + diff --git a/meschach/update.c b/meschach/update.c new file mode 100644 index 0000000..75cdb4f --- /dev/null +++ b/meschach/update.c @@ -0,0 +1,131 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Matrix factorisation routines to work with the other matrix files. +*/ + +/* update.c 1.3 11/25/87 */ +static char rcsid[] = "$Id: update.c,v 1.1 2001/03/01 17:19:13 rfranke Exp $"; + +#include +#include +#include "matrix.h" +#include "matrix2.h" + + + + +/* Most matrix factorisation routines are in-situ unless otherwise specified */ + +/* LDLupdate -- updates a CHolesky factorisation, replacing LDL' by + MD~M' = LDL' + alpha.w.w' Note: w is overwritten + Ref: Gill et al Math Comp 28, p516 Algorithm C1 */ +MAT *LDLupdate(CHmat,w,alpha) +MAT *CHmat; +VEC *w; +double alpha; +{ + u_int i,j; + Real diag,new_diag,beta,p; + + if ( CHmat==(MAT *)NULL || w==(VEC *)NULL ) + error(E_NULL,"LDLupdate"); + if ( CHmat->m != CHmat->n || w->dim != CHmat->m ) + error(E_SIZES,"LDLupdate"); + + for ( j=0; j < w->dim; j++ ) + { + p = w->ve[j]; + diag = CHmat->me[j][j]; + new_diag = CHmat->me[j][j] = diag + alpha*p*p; + if ( new_diag <= 0.0 ) + error(E_POSDEF,"LDLupdate"); + beta = p*alpha/new_diag; + alpha *= diag/new_diag; + + for ( i=j+1; i < w->dim; i++ ) + { + w->ve[i] -= p*CHmat->me[i][j]; + CHmat->me[i][j] += beta*w->ve[i]; + CHmat->me[j][i] = CHmat->me[i][j]; + } + } + + return (CHmat); +} + + +/* QRupdate -- updates QR factorisation in expanded form (seperate matrices) + Finds Q+, R+ s.t. Q+.R+ = Q.(R+u.v') and Q+ orthogonal, R+ upper triang + Ref: Golub & van Loan Matrix Computations pp437-443 + -- does not update Q if it is NULL */ +MAT *QRupdate(Q,R,u,v) +MAT *Q,*R; +VEC *u,*v; +{ + int i,j,k; + Real c,s,temp; + + if ( ! R || ! u || ! v ) + error(E_NULL,"QRupdate"); + if ( ( Q && ( Q->m != Q->n || R->m != Q->n ) ) || + u->dim != R->m || v->dim != R->n ) + error(E_SIZES,"QRupdate"); + + /* find largest k s.t. u[k] != 0 */ + for ( k=R->m-1; k>=0; k-- ) + if ( u->ve[k] != 0.0 ) + break; + + /* transform R+u.v' to Hessenberg form */ + for ( i=k-1; i>=0; i-- ) + { + /* get Givens rotation */ + givens(u->ve[i],u->ve[i+1],&c,&s); + rot_rows(R,i,i+1,c,s,R); + if ( Q ) + rot_cols(Q,i,i+1,c,s,Q); + rot_vec(u,i,i+1,c,s,u); + } + + /* add into R */ + temp = u->ve[0]; + for ( j=0; jn; j++ ) + R->me[0][j] += temp*v->ve[j]; + + /* transform Hessenberg to upper triangular */ + for ( i=0; ime[i][i],R->me[i+1][i],&c,&s); + rot_rows(R,i,i+1,c,s,R); + if ( Q ) + rot_cols(Q,i,i+1,c,s,Q); + } + + return R; +} + diff --git a/meschach/vecop.c b/meschach/vecop.c new file mode 100644 index 0000000..d9192da --- /dev/null +++ b/meschach/vecop.c @@ -0,0 +1,605 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* vecop.c 1.3 8/18/87 */ + +#include +#include "matrix.h" + +static char rcsid[] = "$Id: vecop.c,v 1.1 2001/03/01 17:19:15 rfranke Exp $"; + + +/* _in_prod -- inner product of two vectors from i0 downwards */ +double _in_prod(a,b,i0) +VEC *a,*b; +u_int i0; +{ + u_int limit; + /* Real *a_v, *b_v; */ + /* register Real sum; */ + + if ( a==(VEC *)NULL || b==(VEC *)NULL ) + error(E_NULL,"_in_prod"); + limit = min(a->dim,b->dim); + if ( i0 > limit ) + error(E_BOUNDS,"_in_prod"); + + return __ip__(&(a->ve[i0]),&(b->ve[i0]),(int)(limit-i0)); + /***************************************** + a_v = &(a->ve[i0]); b_v = &(b->ve[i0]); + for ( i=i0; idim != vector->dim ) + out = v_resize(out,vector->dim); + if ( scalar == 0.0 ) + return v_zero(out); + if ( scalar == 1.0 ) + return v_copy(vector,out); + + __smlt__(vector->ve,(double)scalar,out->ve,(int)(vector->dim)); + /************************************************** + dim = vector->dim; + out_ve = out->ve; vec_ve = vector->ve; + for ( i=0; ive[i] = scalar*vector->ve[i]; + (*out_ve++) = scalar*(*vec_ve++); + **************************************************/ + return (out); +} + +/* v_add -- vector addition -- may be in-situ */ +VEC *v_add(vec1,vec2,out) +VEC *vec1,*vec2,*out; +{ + u_int dim; + /* Real *out_ve, *vec1_ve, *vec2_ve; */ + + if ( vec1==(VEC *)NULL || vec2==(VEC *)NULL ) + error(E_NULL,"v_add"); + if ( vec1->dim != vec2->dim ) + error(E_SIZES,"v_add"); + if ( out==(VEC *)NULL || out->dim != vec1->dim ) + out = v_resize(out,vec1->dim); + dim = vec1->dim; + __add__(vec1->ve,vec2->ve,out->ve,(int)dim); + /************************************************************ + out_ve = out->ve; vec1_ve = vec1->ve; vec2_ve = vec2->ve; + for ( i=0; ive[i] = vec1->ve[i]+vec2->ve[i]; + (*out_ve++) = (*vec1_ve++) + (*vec2_ve++); + ************************************************************/ + + return (out); +} + +/* v_mltadd -- scalar/vector multiplication and addition + -- out = v1 + scale.v2 */ +VEC *v_mltadd(v1,v2,scale,out) +VEC *v1,*v2,*out; +double scale; +{ + /* register u_int dim, i; */ + /* Real *out_ve, *v1_ve, *v2_ve; */ + + if ( v1==(VEC *)NULL || v2==(VEC *)NULL ) + error(E_NULL,"v_mltadd"); + if ( v1->dim != v2->dim ) + error(E_SIZES,"v_mltadd"); + if ( scale == 0.0 ) + return v_copy(v1,out); + if ( scale == 1.0 ) + return v_add(v1,v2,out); + + if ( v2 != out ) + { + tracecatch(out = v_copy(v1,out),"v_mltadd"); + + /* dim = v1->dim; */ + __mltadd__(out->ve,v2->ve,scale,(int)(v1->dim)); + } + else + { + tracecatch(out = sv_mlt(scale,v2,out),"v_mltadd"); + out = v_add(v1,out,out); + } + /************************************************************ + out_ve = out->ve; v1_ve = v1->ve; v2_ve = v2->ve; + for ( i=0; i < dim ; i++ ) + out->ve[i] = v1->ve[i] + scale*v2->ve[i]; + (*out_ve++) = (*v1_ve++) + scale*(*v2_ve++); + ************************************************************/ + + return (out); +} + +/* v_sub -- vector subtraction -- may be in-situ */ +VEC *v_sub(vec1,vec2,out) +VEC *vec1,*vec2,*out; +{ + /* u_int i, dim; */ + /* Real *out_ve, *vec1_ve, *vec2_ve; */ + + if ( vec1==(VEC *)NULL || vec2==(VEC *)NULL ) + error(E_NULL,"v_sub"); + if ( vec1->dim != vec2->dim ) + error(E_SIZES,"v_sub"); + if ( out==(VEC *)NULL || out->dim != vec1->dim ) + out = v_resize(out,vec1->dim); + + __sub__(vec1->ve,vec2->ve,out->ve,(int)(vec1->dim)); + /************************************************************ + dim = vec1->dim; + out_ve = out->ve; vec1_ve = vec1->ve; vec2_ve = vec2->ve; + for ( i=0; ive[i] = vec1->ve[i]-vec2->ve[i]; + (*out_ve++) = (*vec1_ve++) - (*vec2_ve++); + ************************************************************/ + + return (out); +} + +/* v_map -- maps function f over components of x: out[i] = f(x[i]) + -- _v_map sets out[i] = f(params,x[i]) */ +VEC *v_map(f,x,out) +#ifdef PROTOTYPES_IN_STRUCT +double (*f)(double); +#else +double (*f)(); +#endif +VEC *x, *out; +{ + Real *x_ve, *out_ve; + int i, dim; + + if ( ! x || ! f ) + error(E_NULL,"v_map"); + if ( ! out || out->dim != x->dim ) + out = v_resize(out,x->dim); + + dim = x->dim; x_ve = x->ve; out_ve = out->ve; + for ( i = 0; i < dim; i++ ) + *out_ve++ = (*f)(*x_ve++); + + return out; +} + +VEC *_v_map(f,params,x,out) +#ifdef PROTOTYPES_IN_STRUCT +double (*f)(void *,double); +#else +double (*f)(); +#endif +VEC *x, *out; +void *params; +{ + Real *x_ve, *out_ve; + int i, dim; + + if ( ! x || ! f ) + error(E_NULL,"_v_map"); + if ( ! out || out->dim != x->dim ) + out = v_resize(out,x->dim); + + dim = x->dim; x_ve = x->ve; out_ve = out->ve; + for ( i = 0; i < dim; i++ ) + *out_ve++ = (*f)(params,*x_ve++); + + return out; +} + +/* v_lincomb -- returns sum_i a[i].v[i], a[i] real, v[i] vectors */ +VEC *v_lincomb(n,v,a,out) +int n; /* number of a's and v's */ +Real a[]; +VEC *v[], *out; +{ + int i; + + if ( ! a || ! v ) + error(E_NULL,"v_lincomb"); + if ( n <= 0 ) + return VNULL; + + for ( i = 1; i < n; i++ ) + if ( out == v[i] ) + error(E_INSITU,"v_lincomb"); + + out = sv_mlt(a[0],v[0],out); + for ( i = 1; i < n; i++ ) + { + if ( ! v[i] ) + error(E_NULL,"v_lincomb"); + if ( v[i]->dim != out->dim ) + error(E_SIZES,"v_lincomb"); + out = v_mltadd(out,v[i],a[i],out); + } + + return out; +} + + + +#ifdef ANSI_C + +/* v_linlist -- linear combinations taken from a list of arguments; + calling: + v_linlist(out,v1,a1,v2,a2,...,vn,an,NULL); + where vi are vectors (VEC *) and ai are numbers (double) +*/ +VEC *v_linlist(VEC *out,VEC *v1,double a1,...) +{ + va_list ap; + VEC *par; + double a_par; + + if ( ! v1 ) + return VNULL; + + va_start(ap, a1); + out = sv_mlt(a1,v1,out); + + while (par = va_arg(ap,VEC *)) { /* NULL ends the list*/ + a_par = va_arg(ap,double); + if (a_par == 0.0) continue; + if ( out == par ) + error(E_INSITU,"v_linlist"); + if ( out->dim != par->dim ) + error(E_SIZES,"v_linlist"); + + if (a_par == 1.0) + out = v_add(out,par,out); + else if (a_par == -1.0) + out = v_sub(out,par,out); + else + out = v_mltadd(out,par,a_par,out); + } + + va_end(ap); + return out; +} + +#elif VARARGS + + +/* v_linlist -- linear combinations taken from a list of arguments; + calling: + v_linlist(out,v1,a1,v2,a2,...,vn,an,NULL); + where vi are vectors (VEC *) and ai are numbers (double) +*/ +VEC *v_linlist(va_alist) va_dcl +{ + va_list ap; + VEC *par, *out; + double a_par; + + va_start(ap); + out = va_arg(ap,VEC *); + par = va_arg(ap,VEC *); + if ( ! par ) { + va_end(ap); + return VNULL; + } + + a_par = va_arg(ap,double); + out = sv_mlt(a_par,par,out); + + while (par = va_arg(ap,VEC *)) { /* NULL ends the list*/ + a_par = va_arg(ap,double); + if (a_par == 0.0) continue; + if ( out == par ) + error(E_INSITU,"v_linlist"); + if ( out->dim != par->dim ) + error(E_SIZES,"v_linlist"); + + if (a_par == 1.0) + out = v_add(out,par,out); + else if (a_par == -1.0) + out = v_sub(out,par,out); + else + out = v_mltadd(out,par,a_par,out); + } + + va_end(ap); + return out; +} + +#endif + + + + + +/* v_star -- computes componentwise (Hadamard) product of x1 and x2 + -- result out is returned */ +VEC *v_star(x1, x2, out) +VEC *x1, *x2, *out; +{ + int i; + + if ( ! x1 || ! x2 ) + error(E_NULL,"v_star"); + if ( x1->dim != x2->dim ) + error(E_SIZES,"v_star"); + out = v_resize(out,x1->dim); + + for ( i = 0; i < x1->dim; i++ ) + out->ve[i] = x1->ve[i] * x2->ve[i]; + + return out; +} + +/* v_slash -- computes componentwise ratio of x2 and x1 + -- out[i] = x2[i] / x1[i] + -- if x1[i] == 0 for some i, then raise E_SING error + -- result out is returned */ +VEC *v_slash(x1, x2, out) +VEC *x1, *x2, *out; +{ + int i; + Real tmp; + + if ( ! x1 || ! x2 ) + error(E_NULL,"v_slash"); + if ( x1->dim != x2->dim ) + error(E_SIZES,"v_slash"); + out = v_resize(out,x1->dim); + + for ( i = 0; i < x1->dim; i++ ) + { + tmp = x1->ve[i]; + if ( tmp == 0.0 ) + error(E_SING,"v_slash"); + out->ve[i] = x2->ve[i] / tmp; + } + + return out; +} + +/* v_min -- computes minimum component of x, which is returned + -- also sets min_idx to the index of this minimum */ +double v_min(x, min_idx) +VEC *x; +int *min_idx; +{ + int i, i_min; + Real min_val, tmp; + + if ( ! x ) + error(E_NULL,"v_min"); + if ( x->dim <= 0 ) + error(E_SIZES,"v_min"); + i_min = 0; + min_val = x->ve[0]; + for ( i = 1; i < x->dim; i++ ) + { + tmp = x->ve[i]; + if ( tmp < min_val ) + { + min_val = tmp; + i_min = i; + } + } + + if ( min_idx != NULL ) + *min_idx = i_min; + return min_val; +} + +/* v_max -- computes maximum component of x, which is returned + -- also sets max_idx to the index of this maximum */ +double v_max(x, max_idx) +VEC *x; +int *max_idx; +{ + int i, i_max; + Real max_val, tmp; + + if ( ! x ) + error(E_NULL,"v_max"); + if ( x->dim <= 0 ) + error(E_SIZES,"v_max"); + i_max = 0; + max_val = x->ve[0]; + for ( i = 1; i < x->dim; i++ ) + { + tmp = x->ve[i]; + if ( tmp > max_val ) + { + max_val = tmp; + i_max = i; + } + } + + if ( max_idx != NULL ) + *max_idx = i_max; + return max_val; +} + +#define MAX_STACK 60 + + +/* v_sort -- sorts vector x, and generates permutation that gives the order + of the components; x = [1.3, 3.7, 0.5] -> [0.5, 1.3, 3.7] and + the permutation is order = [2, 0, 1]. + -- if order is NULL on entry then it is ignored + -- the sorted vector x is returned */ +VEC *v_sort(x, order) +VEC *x; +PERM *order; +{ + Real *x_ve, tmp, v; + /* int *order_pe; */ + int dim, i, j, l, r, tmp_i; + int stack[MAX_STACK], sp; + + if ( ! x ) + error(E_NULL,"v_sort"); + if ( order != PNULL && order->size != x->dim ) + order = px_resize(order, x->dim); + + x_ve = x->ve; + dim = x->dim; + if ( order != PNULL ) + px_ident(order); + + if ( dim <= 1 ) + return x; + + /* using quicksort algorithm in Sedgewick, + "Algorithms in C", Ch. 9, pp. 118--122 (1990) */ + sp = 0; + l = 0; r = dim-1; v = x_ve[0]; + for ( ; ; ) + { + while ( r > l ) + { + /* "i = partition(x_ve,l,r);" */ + v = x_ve[r]; + i = l-1; + j = r; + for ( ; ; ) + { + while ( x_ve[++i] < v ) + ; + while ( x_ve[--j] > v ) + ; + if ( i >= j ) break; + + tmp = x_ve[i]; + x_ve[i] = x_ve[j]; + x_ve[j] = tmp; + if ( order != PNULL ) + { + tmp_i = order->pe[i]; + order->pe[i] = order->pe[j]; + order->pe[j] = tmp_i; + } + } + tmp = x_ve[i]; + x_ve[i] = x_ve[r]; + x_ve[r] = tmp; + if ( order != PNULL ) + { + tmp_i = order->pe[i]; + order->pe[i] = order->pe[r]; + order->pe[r] = tmp_i; + } + + if ( i-l > r-i ) + { stack[sp++] = l; stack[sp++] = i-1; l = i+1; } + else + { stack[sp++] = i+1; stack[sp++] = r; r = i-1; } + } + + /* recursion elimination */ + if ( sp == 0 ) + break; + r = stack[--sp]; + l = stack[--sp]; + } + + return x; +} + +/* v_sum -- returns sum of entries of a vector */ +double v_sum(x) +VEC *x; +{ + int i; + Real sum; + + if ( ! x ) + error(E_NULL,"v_sum"); + + sum = 0.0; + for ( i = 0; i < x->dim; i++ ) + sum += x->ve[i]; + + return sum; +} + +/* v_conv -- computes convolution product of two vectors */ +VEC *v_conv(x1, x2, out) +VEC *x1, *x2, *out; +{ + int i; + + if ( ! x1 || ! x2 ) + error(E_NULL,"v_conv"); + if ( x1 == out || x2 == out ) + error(E_INSITU,"v_conv"); + if ( x1->dim == 0 || x2->dim == 0 ) + return out = v_resize(out,0); + + out = v_resize(out,x1->dim + x2->dim - 1); + v_zero(out); + for ( i = 0; i < x1->dim; i++ ) + __mltadd__(&(out->ve[i]),x2->ve,x1->ve[i],x2->dim); + + return out; +} + +/* v_pconv -- computes a periodic convolution product + -- the period is the dimension of x2 */ +VEC *v_pconv(x1, x2, out) +VEC *x1, *x2, *out; +{ + int i; + + if ( ! x1 || ! x2 ) + error(E_NULL,"v_pconv"); + if ( x1 == out || x2 == out ) + error(E_INSITU,"v_pconv"); + out = v_resize(out,x2->dim); + if ( x2->dim == 0 ) + return out; + + v_zero(out); + for ( i = 0; i < x1->dim; i++ ) + { + __mltadd__(&(out->ve[i]),x2->ve,x1->ve[i],x2->dim - i); + if ( i > 0 ) + __mltadd__(out->ve,&(x2->ve[x2->dim - i]),x1->ve[i],i); + } + + return out; +} diff --git a/meschach/version.c b/meschach/version.c new file mode 100644 index 0000000..b4ccf00 --- /dev/null +++ b/meschach/version.c @@ -0,0 +1,118 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* Version routine */ +/* This routine must be modified whenever modifications are made to + Meschach by persons other than the original authors + (David E. Stewart & Zbigniew Leyk); + when new releases of Meschach are made the + version number will also be updated +*/ + +#include + +void m_version() +{ + static char rcsid[] = "$Id: version.c,v 1.1 2001/03/01 17:19:15 rfranke Exp $"; + + printf("Meshach matrix library version 1.2b\n"); + printf("RCS id: %s\n",rcsid); + printf("Changes since 1.2a:\n"); + printf("\t Fixed bug in schur() for 2x2 blocks with real e-vals\n"); + printf("\t Fixed bug in schur() reading beyond end of array\n"); + printf("\t Fixed some installation bugs\n"); + printf("\t Fixed bugs & improved efficiency in spILUfactor()\n"); + printf("\t px_inv() doesn't crash inverting non-permutations\n"); + /**** List of modifications ****/ + /* Example below is for illustration only */ + /* printf("Modified by %s, routine(s) %s, file %s on date %s\n", + "Joe Bloggs", + "m_version", + "version.c", + "Fri Apr 5 16:00:38 EST 1994"); */ + /* printf("Purpose: %s\n", + "To update the version number"); */ + printf("Changes made by Ruediger Franke for HQP\n"); + printf("\tmatrix.h, sparse.h: brought function prototypes to ANSI C\n"); + printf("\tmatrix.h: increased MAXDIM to M_MAX_INT to work around a bug in iv_free()\n"); + printf("\tvecop.c, v_resize(): fixed memory allocation bug for dim == 0\n"); + printf("\tpxop.c, pxinv_vec(): replaced with a new version\n"); + printf("\tmachine.h: introduced defining SPARSE_COL_ACCESS for conditional compilation of column accesses\n"); + printf("\tsparse.h, sparse.c, sparseio.c, sprow.c: excluded code for column accesses with conditional compilation\n"); + printf("\tmakefile: excluded spchfctr.o, splufctr.o, spbkp.o, and spswap.o from the library\n"); + /* rf, 2/17/98 */ + printf("\tcopy.c: _m_copy(), _v_copy() call resize() for any changing dimension, not only for increase\n"); + /* rf, 6/18/98 */ + printf("\tmatrixio.c: bm_finput(), bfin_vec(): call resize() for changing dimension, not only for NULL pointer\n"); + /* rf, 9/11/98 */ + printf("\tsparse.h, sparsdef.h: replaced pair with SPPAIR to avoid name conflict with STL (Par Winzell)\n"); + /* rf, 10/27/00 */ + printf("\thessen.c, Hfactor: check for numerical overflow after call to hvec() in hsehldr.c to avoid infinite loop in symmeig()\n"); + /* rf, 12/05/00 */ + printf("\tmove err.h to m_err.h (name conflict with /usr/include/err.h)\n"); + printf("\tm_err.h: rename macro \"catch\" to \"m_catch\" (conflict with C++ keyword)\n"); + printf("\n"); +} + +/* $Log: version.c,v $ +/* Revision 1.1 2001/03/01 17:19:15 rfranke +/* Initial revision +/* +/* Revision 1.4 2000/12/05 09:42:57 rf +/* 12/05/00: rf: resolve meschach/err.h, catch conflict +/* - configure.in: change version to 1.7a5 +/* - rename meschach/err.h to meschach/m_err.h +/* - m_err.h: rename macro catch to m_catch +/* - adapt meschach/{matrix.h, err.c, torture.c, ztorture.c, makefile, +/* version.c} +/* - hqp/Meschach.h: don't need to redefine catch anymore +/* - hqp/Hqp_IpsMehrotra.C, hqp/HqpIpsFranke.C: use m_catch +/* +/* Revision 1.3 2000/11/01 21:39:02 rf +/* 11/01/00: rf: +/* - bug fix in meschach/hessen.c after call to hhvec in hsehldr.c +/* to avoid infinite loop in symmeig() +/* - hqp/Hqp_HL_BFGS.C: change default _eigen_control to true +/* - omu/Omu_IntDASPK.C (realloc): more sensible allocation of memory +/* when using direct solver +/* +/* Revision 1.2 2000/04/11 18:45:23 rf +/* removed nested comments at end of file +/* + * Revision 1.1.1.1 2000/04/04 07:25:42 ea + * CVS initial version 1.6a4 + * + * Revision 1.9 1994/03/24 00:04:05 des + * Added notes on changes to spILUfactor() and px_inv(). + * + * Revision 1.8 1994/02/21 04:32:25 des + * Set version to 1.2b with bug fixes in schur() and installation. + * + * Revision 1.7 1994/01/13 05:43:57 des + * Version 1.2 update + * + + * */ diff --git a/meschach/zcopy.c b/meschach/zcopy.c new file mode 100644 index 0000000..fa3ef77 --- /dev/null +++ b/meschach/zcopy.c @@ -0,0 +1,192 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +static char rcsid[] = "$Id: zcopy.c,v 1.1 2001/03/01 17:19:15 rfranke Exp $"; +#include +#include "zmatrix.h" + + + +/* _zm_copy -- copies matrix into new area */ +ZMAT *_zm_copy(in,out,i0,j0) +ZMAT *in,*out; +u_int i0,j0; +{ + u_int i /* ,j */; + + if ( in==ZMNULL ) + error(E_NULL,"_zm_copy"); + if ( in==out ) + return (out); + if ( out==ZMNULL || out->m < in->m || out->n < in->n ) + out = zm_resize(out,in->m,in->n); + + for ( i=i0; i < in->m; i++ ) + MEM_COPY(&(in->me[i][j0]),&(out->me[i][j0]), + (in->n - j0)*sizeof(complex)); + /* for ( j=j0; j < in->n; j++ ) + out->me[i][j] = in->me[i][j]; */ + + return (out); +} + +/* _zv_copy -- copies vector into new area */ +ZVEC *_zv_copy(in,out,i0) +ZVEC *in,*out; +u_int i0; +{ + /* u_int i,j; */ + + if ( in==ZVNULL ) + error(E_NULL,"_zv_copy"); + if ( in==out ) + return (out); + if ( out==ZVNULL || out->dim < in->dim ) + out = zv_resize(out,in->dim); + + MEM_COPY(&(in->ve[i0]),&(out->ve[i0]),(in->dim - i0)*sizeof(complex)); + /* for ( i=i0; i < in->dim; i++ ) + out->ve[i] = in->ve[i]; */ + + return (out); +} + + +/* + The z._move() routines are for moving blocks of memory around + within Meschach data structures and for re-arranging matrices, + vectors etc. +*/ + +/* zm_move -- copies selected pieces of a matrix + -- moves the m0 x n0 submatrix with top-left cor-ordinates (i0,j0) + to the corresponding submatrix of out with top-left co-ordinates + (i1,j1) + -- out is resized (& created) if necessary */ +ZMAT *zm_move(in,i0,j0,m0,n0,out,i1,j1) +ZMAT *in, *out; +int i0, j0, m0, n0, i1, j1; +{ + int i; + + if ( ! in ) + error(E_NULL,"zm_move"); + if ( i0 < 0 || j0 < 0 || i1 < 0 || j1 < 0 || m0 < 0 || n0 < 0 || + i0+m0 > in->m || j0+n0 > in->n ) + error(E_BOUNDS,"zm_move"); + + if ( ! out ) + out = zm_resize(out,i1+m0,j1+n0); + else if ( i1+m0 > out->m || j1+n0 > out->n ) + out = zm_resize(out,max(out->m,i1+m0),max(out->n,j1+n0)); + + for ( i = 0; i < m0; i++ ) + MEM_COPY(&(in->me[i0+i][j0]),&(out->me[i1+i][j1]), + n0*sizeof(complex)); + + return out; +} + +/* zv_move -- copies selected pieces of a vector + -- moves the length dim0 subvector with initial index i0 + to the corresponding subvector of out with initial index i1 + -- out is resized if necessary */ +ZVEC *zv_move(in,i0,dim0,out,i1) +ZVEC *in, *out; +int i0, dim0, i1; +{ + if ( ! in ) + error(E_NULL,"zv_move"); + if ( i0 < 0 || dim0 < 0 || i1 < 0 || + i0+dim0 > in->dim ) + error(E_BOUNDS,"zv_move"); + + if ( (! out) || i1+dim0 > out->dim ) + out = zv_resize(out,i1+dim0); + + MEM_COPY(&(in->ve[i0]),&(out->ve[i1]),dim0*sizeof(complex)); + + return out; +} + + +/* zmv_move -- copies selected piece of matrix to a vector + -- moves the m0 x n0 submatrix with top-left co-ordinate (i0,j0) to + the subvector with initial index i1 (and length m0*n0) + -- rows are copied contiguously + -- out is resized if necessary */ +ZVEC *zmv_move(in,i0,j0,m0,n0,out,i1) +ZMAT *in; +ZVEC *out; +int i0, j0, m0, n0, i1; +{ + int dim1, i; + + if ( ! in ) + error(E_NULL,"zmv_move"); + if ( i0 < 0 || j0 < 0 || m0 < 0 || n0 < 0 || i1 < 0 || + i0+m0 > in->m || j0+n0 > in->n ) + error(E_BOUNDS,"zmv_move"); + + dim1 = m0*n0; + if ( (! out) || i1+dim1 > out->dim ) + out = zv_resize(out,i1+dim1); + + for ( i = 0; i < m0; i++ ) + MEM_COPY(&(in->me[i0+i][j0]),&(out->ve[i1+i*n0]),n0*sizeof(complex)); + + return out; +} + +/* zvm_move -- copies selected piece of vector to a matrix + -- moves the subvector with initial index i0 and length m1*n1 to + the m1 x n1 submatrix with top-left co-ordinate (i1,j1) + -- copying is done by rows + -- out is resized if necessary */ +ZMAT *zvm_move(in,i0,out,i1,j1,m1,n1) +ZVEC *in; +ZMAT *out; +int i0, i1, j1, m1, n1; +{ + int dim0, i; + + if ( ! in ) + error(E_NULL,"zvm_move"); + if ( i0 < 0 || i1 < 0 || j1 < 0 || m1 < 0 || n1 < 0 || + i0+m1*n1 > in->dim ) + error(E_BOUNDS,"zvm_move"); + + if ( ! out ) + out = zm_resize(out,i1+m1,j1+n1); + else + out = zm_resize(out,max(i1+m1,out->m),max(j1+n1,out->n)); + + dim0 = m1*n1; + for ( i = 0; i < m1; i++ ) + MEM_COPY(&(in->ve[i0+i*n1]),&(out->me[i1+i][j1]),n1*sizeof(complex)); + + return out; +} diff --git a/meschach/zfunc.c b/meschach/zfunc.c new file mode 100644 index 0000000..0133333 --- /dev/null +++ b/meschach/zfunc.c @@ -0,0 +1,236 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + +/* + Elementary functions for complex numbers + -- if not already defined +*/ + +#include +#include "zmatrix.h" + +static char rcsid[] = "$Id: zfunc.c,v 1.1 2001/03/01 17:19:15 rfranke Exp $"; + +#ifndef COMPLEX_H + +#ifndef zmake +/* zmake -- create complex number real + i*imag */ +complex zmake(real,imag) +double real, imag; +{ + complex w; /* == real + i*imag */ + + w.re = real; w.im = imag; + return w; +} +#endif + +#ifndef zneg +/* zneg -- returns negative of z */ +complex zneg(z) +complex z; +{ + z.re = - z.re; + z.im = - z.im; + + return z; +} +#endif + +#ifndef zabs +/* zabs -- returns |z| */ +double zabs(z) +complex z; +{ + Real x, y, tmp; + int x_expt, y_expt; + + /* Note: we must ensure that overflow does not occur! */ + x = ( z.re >= 0.0 ) ? z.re : -z.re; + y = ( z.im >= 0.0 ) ? z.im : -z.im; + if ( x < y ) + { + tmp = x; + x = y; + y = tmp; + } + x = frexp(x,&x_expt); + y = frexp(y,&y_expt); + y = ldexp(y,y_expt-x_expt); + tmp = sqrt(x*x+y*y); + + return ldexp(tmp,x_expt); +} +#endif + +#ifndef zadd +/* zadd -- returns z1+z2 */ +complex zadd(z1,z2) +complex z1, z2; +{ + complex z; + + z.re = z1.re + z2.re; + z.im = z1.im + z2.im; + + return z; +} +#endif + +#ifndef zsub +/* zsub -- returns z1-z2 */ +complex zsub(z1,z2) +complex z1, z2; +{ + complex z; + + z.re = z1.re - z2.re; + z.im = z1.im - z2.im; + + return z; +} +#endif + +#ifndef zmlt +/* zmlt -- returns z1*z2 */ +complex zmlt(z1,z2) +complex z1, z2; +{ + complex z; + + z.re = z1.re * z2.re - z1.im * z2.im; + z.im = z1.re * z2.im + z1.im * z2.re; + + return z; +} +#endif + +#ifndef zinv +/* zmlt -- returns 1/z */ +complex zinv(z) +complex z; +{ + Real x, y, tmp; + int x_expt, y_expt; + + if ( z.re == 0.0 && z.im == 0.0 ) + error(E_SING,"zinv"); + /* Note: we must ensure that overflow does not occur! */ + x = ( z.re >= 0.0 ) ? z.re : -z.re; + y = ( z.im >= 0.0 ) ? z.im : -z.im; + if ( x < y ) + { + tmp = x; + x = y; + y = tmp; + } + x = frexp(x,&x_expt); + y = frexp(y,&y_expt); + y = ldexp(y,y_expt-x_expt); + + tmp = 1.0/(x*x + y*y); + z.re = z.re*tmp*ldexp(1.0,-2*x_expt); + z.im = -z.im*tmp*ldexp(1.0,-2*x_expt); + + return z; +} +#endif + +#ifndef zdiv +/* zdiv -- returns z1/z2 */ +complex zdiv(z1,z2) +complex z1, z2; +{ + return zmlt(z1,zinv(z2)); +} +#endif + +#ifndef zsqrt +/* zsqrt -- returns sqrt(z); uses branch with Re sqrt(z) >= 0 */ +complex zsqrt(z) +complex z; +{ + complex w; /* == sqrt(z) at end */ + Real alpha; + + alpha = sqrt(0.5*(fabs(z.re) + zabs(z))); + if ( z.re >= 0.0 ) + { + w.re = alpha; + w.im = z.im / (2.0*alpha); + } + else + { + w.re = fabs(z.im)/(2.0*alpha); + w.im = ( z.im >= 0 ) ? alpha : - alpha; + } + + return w; +} +#endif + +#ifndef zexp +/* zexp -- returns exp(z) */ +complex zexp(z) +complex z; +{ + complex w; /* == exp(z) at end */ + Real r; + + r = exp(z.re); + w.re = r*cos(z.im); + w.im = r*sin(z.im); + + return w; +} +#endif + +#ifndef zlog +/* zlog -- returns log(z); uses principal branch with -pi <= Im log(z) <= pi */ +complex zlog(z) +complex z; +{ + complex w; /* == log(z) at end */ + + w.re = log(zabs(z)); + w.im = atan2(z.im,z.re); + + return w; +} +#endif + +#ifndef zconj +complex zconj(z) +complex z; +{ + complex w; /* == conj(z) */ + + w.re = z.re; + w.im = - z.im; + return w; +} +#endif + +#endif diff --git a/meschach/zgivens.c b/meschach/zgivens.c new file mode 100644 index 0000000..4ac698d --- /dev/null +++ b/meschach/zgivens.c @@ -0,0 +1,180 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Givens operations file. Contains routines for calculating and + applying givens rotations for/to vectors and also to matrices by + row and by column. + + Complex version. +*/ + +static char rcsid[] = "$Id: "; + +#include +#include +#include "zmatrix.h" +#include "zmatrix2.h" + +/* + (Complex) Givens rotation matrix: + [ c -s ] + [ s* c ] + Note that c is real and s is complex +*/ + +/* zgivens -- returns c,s parameters for Givens rotation to + eliminate y in the **column** vector [ x y ] */ +void zgivens(x,y,c,s) +complex x,y,*s; +Real *c; +{ + Real inv_norm, norm; + complex tmp; + + /* this is a safe way of computing sqrt(|x|^2+|y|^2) */ + tmp.re = zabs(x); tmp.im = zabs(y); + norm = zabs(tmp); + + if ( norm == 0.0 ) + { *c = 1.0; s->re = s->im = 0.0; } /* identity */ + else + { + inv_norm = 1.0 / tmp.re; /* inv_norm = 1/|x| */ + x.re *= inv_norm; + x.im *= inv_norm; /* normalise x */ + inv_norm = 1.0/norm; /* inv_norm = 1/||[x,y]||2 */ + *c = tmp.re * inv_norm; + /* now compute - conj(normalised x).y/||[x,y]||2 */ + s->re = - inv_norm*(x.re*y.re + x.im*y.im); + s->im = inv_norm*(x.re*y.im - x.im*y.re); + } +} + +/* rot_zvec -- apply Givens rotation to x's i & k components */ +ZVEC *rot_zvec(x,i,k,c,s,out) +ZVEC *x,*out; +int i,k; +double c; +complex s; +{ + + complex temp1, temp2; + + if ( x==ZVNULL ) + error(E_NULL,"rot_zvec"); + if ( i < 0 || i >= x->dim || k < 0 || k >= x->dim ) + error(E_RANGE,"rot_zvec"); + if ( x != out ) + out = zv_copy(x,out); + + /* temp1 = c*out->ve[i] - s*out->ve[k]; */ + temp1.re = c*out->ve[i].re + - s.re*out->ve[k].re + s.im*out->ve[k].im; + temp1.im = c*out->ve[i].im + - s.re*out->ve[k].im - s.im*out->ve[k].re; + + /* temp2 = c*out->ve[k] + zconj(s)*out->ve[i]; */ + temp2.re = c*out->ve[k].re + + s.re*out->ve[i].re + s.im*out->ve[i].im; + temp2.im = c*out->ve[k].im + + s.re*out->ve[i].im - s.im*out->ve[i].re; + + out->ve[i] = temp1; + out->ve[k] = temp2; + + return (out); +} + +/* zrot_rows -- premultiply mat by givens rotation described by c,s */ +ZMAT *zrot_rows(mat,i,k,c,s,out) +ZMAT *mat,*out; +int i,k; +double c; +complex s; +{ + u_int j; + complex temp1, temp2; + + if ( mat==ZMNULL ) + error(E_NULL,"zrot_rows"); + if ( i < 0 || i >= mat->m || k < 0 || k >= mat->m ) + error(E_RANGE,"zrot_rows"); + out = zm_copy(mat,out); + + /* temp1 = c*out->me[i][j] - s*out->me[k][j]; */ + for ( j=0; jn; j++ ) + { + /* temp1 = c*out->me[i][j] - s*out->me[k][j]; */ + temp1.re = c*out->me[i][j].re + - s.re*out->me[k][j].re + s.im*out->me[k][j].im; + temp1.im = c*out->me[i][j].im + - s.re*out->me[k][j].im - s.im*out->me[k][j].re; + + /* temp2 = c*out->me[k][j] + conj(s)*out->me[i][j]; */ + temp2.re = c*out->me[k][j].re + + s.re*out->me[i][j].re + s.im*out->me[i][j].im; + temp2.im = c*out->me[k][j].im + + s.re*out->me[i][j].im - s.im*out->me[i][j].re; + + out->me[i][j] = temp1; + out->me[k][j] = temp2; + } + + return (out); +} + +/* zrot_cols -- postmultiply mat by adjoint Givens rotation described by c,s */ +ZMAT *zrot_cols(mat,i,k,c,s,out) +ZMAT *mat,*out; +int i,k; +double c; +complex s; +{ + u_int j; + complex x, y; + + if ( mat==ZMNULL ) + error(E_NULL,"zrot_cols"); + if ( i < 0 || i >= mat->n || k < 0 || k >= mat->n ) + error(E_RANGE,"zrot_cols"); + out = zm_copy(mat,out); + + for ( j=0; jm; j++ ) + { + x = out->me[j][i]; y = out->me[j][k]; + /* out->me[j][i] = c*x - conj(s)*y; */ + out->me[j][i].re = c*x.re - s.re*y.re - s.im*y.im; + out->me[j][i].im = c*x.im - s.re*y.im + s.im*y.re; + + /* out->me[j][k] = c*y + s*x; */ + out->me[j][k].re = c*y.re + s.re*x.re - s.im*x.im; + out->me[j][k].im = c*y.im + s.re*x.im + s.im*x.re; + } + + return (out); +} + diff --git a/meschach/zhessen.c b/meschach/zhessen.c new file mode 100644 index 0000000..a09474d --- /dev/null +++ b/meschach/zhessen.c @@ -0,0 +1,152 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + File containing routines for determining Hessenberg + factorisations. + + Complex version +*/ + +static char rcsid[] = "$Id: zhessen.c,v 1.1 2001/03/01 17:19:16 rfranke Exp $"; + +#include +#include "zmatrix.h" +#include "zmatrix2.h" + + +/* zHfactor -- compute Hessenberg factorisation in compact form. + -- factorisation performed in situ + -- for details of the compact form see zQRfactor.c and zmatrix2.doc */ +ZMAT *zHfactor(A, diag) +ZMAT *A; +ZVEC *diag; +{ + static ZVEC *tmp1 = ZVNULL; + Real beta; + int k, limit; + + if ( ! A || ! diag ) + error(E_NULL,"zHfactor"); + if ( diag->dim < A->m - 1 ) + error(E_SIZES,"zHfactor"); + if ( A->m != A->n ) + error(E_SQUARE,"zHfactor"); + limit = A->m - 1; + + tmp1 = zv_resize(tmp1,A->m); + MEM_STAT_REG(tmp1,TYPE_ZVEC); + + for ( k = 0; k < limit; k++ ) + { + zget_col(A,k,tmp1); + zhhvec(tmp1,k+1,&beta,tmp1,&A->me[k+1][k]); + diag->ve[k] = tmp1->ve[k+1]; + /* printf("zHfactor: k = %d, beta = %g, tmp1 =\n",k,beta); + zv_output(tmp1); */ + + zhhtrcols(A,k+1,k+1,tmp1,beta); + zhhtrrows(A,0 ,k+1,tmp1,beta); + /* printf("# at stage k = %d, A =\n",k); zm_output(A); */ + } + + return (A); +} + +/* zHQunpack -- unpack the compact representation of H and Q of a + Hessenberg factorisation + -- if either H or Q is NULL, then it is not unpacked + -- it can be in situ with HQ == H + -- returns HQ +*/ +ZMAT *zHQunpack(HQ,diag,Q,H) +ZMAT *HQ, *Q, *H; +ZVEC *diag; +{ + int i, j, limit; + Real beta, r_ii, tmp_val; + static ZVEC *tmp1 = ZVNULL, *tmp2 = ZVNULL; + + if ( HQ==ZMNULL || diag==ZVNULL ) + error(E_NULL,"zHQunpack"); + if ( HQ == Q || H == Q ) + error(E_INSITU,"zHQunpack"); + limit = HQ->m - 1; + if ( diag->dim < limit ) + error(E_SIZES,"zHQunpack"); + if ( HQ->m != HQ->n ) + error(E_SQUARE,"zHQunpack"); + + + if ( Q != ZMNULL ) + { + Q = zm_resize(Q,HQ->m,HQ->m); + tmp1 = zv_resize(tmp1,H->m); + tmp2 = zv_resize(tmp2,H->m); + MEM_STAT_REG(tmp1,TYPE_ZVEC); + MEM_STAT_REG(tmp2,TYPE_ZVEC); + + for ( i = 0; i < H->m; i++ ) + { + /* tmp1 = i'th basis vector */ + for ( j = 0; j < H->m; j++ ) + tmp1->ve[j].re = tmp1->ve[j].im = 0.0; + tmp1->ve[i].re = 1.0; + + /* apply H/h transforms in reverse order */ + for ( j = limit-1; j >= 0; j-- ) + { + zget_col(HQ,j,tmp2); + r_ii = zabs(tmp2->ve[j+1]); + tmp2->ve[j+1] = diag->ve[j]; + tmp_val = (r_ii*zabs(diag->ve[j])); + beta = ( tmp_val == 0.0 ) ? 0.0 : 1.0/tmp_val; + /* printf("zHQunpack: j = %d, beta = %g, tmp2 =\n", + j,beta); + zv_output(tmp2); */ + zhhtrvec(tmp2,beta,j+1,tmp1,tmp1); + } + + /* insert into Q */ + zset_col(Q,i,tmp1); + } + } + + if ( H != ZMNULL ) + { + H = zm_copy(HQ,H); + + limit = H->m; + for ( i = 1; i < limit; i++ ) + for ( j = 0; j < i-1; j++ ) + H->me[i][j].re = H->me[i][j].im = 0.0; + } + + return HQ; +} + + + diff --git a/meschach/zhsehldr.c b/meschach/zhsehldr.c new file mode 100644 index 0000000..18ee98f --- /dev/null +++ b/meschach/zhsehldr.c @@ -0,0 +1,208 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Files for matrix computations + + Householder transformation file. Contains routines for calculating + householder transformations, applying them to vectors and matrices + by both row & column. + + Complex version +*/ + +static char rcsid[] = "$Id: zhsehldr.c,v 1.1 2001/03/01 17:19:17 rfranke Exp $"; + +#include +#include +#include "zmatrix.h" +#include "zmatrix2.h" + +#define is_zero(z) ((z).re == 0.0 && (z).im == 0.0) + +/* zhhvec -- calulates Householder vector to eliminate all entries after the + i0 entry of the vector vec. It is returned as out. May be in-situ */ +ZVEC *zhhvec(vec,i0,beta,out,newval) +ZVEC *vec,*out; +int i0; +Real *beta; +complex *newval; +{ + complex tmp; + Real norm, abs_val; + + if ( i0 < 0 || i0 >= vec->dim ) + error(E_BOUNDS,"zhhvec"); + out = _zv_copy(vec,out,i0); + tmp = _zin_prod(out,out,i0,Z_CONJ); + if ( tmp.re <= 0.0 ) + { + *beta = 0.0; + *newval = out->ve[i0]; + return (out); + } + norm = sqrt(tmp.re); + abs_val = zabs(out->ve[i0]); + *beta = 1.0/(norm * (norm+abs_val)); + if ( abs_val == 0.0 ) + { + newval->re = norm; + newval->im = 0.0; + } + else + { + abs_val = -norm / abs_val; + newval->re = abs_val*out->ve[i0].re; + newval->im = abs_val*out->ve[i0].im; + } abs_val = -norm / abs_val; + out->ve[i0].re -= newval->re; + out->ve[i0].im -= newval->im; + + return (out); +} + +/* zhhtrvec -- apply Householder transformation to vector -- may be in-situ */ +ZVEC *zhhtrvec(hh,beta,i0,in,out) +ZVEC *hh,*in,*out; /* hh = Householder vector */ +int i0; +double beta; +{ + complex scale, tmp; + /* u_int i; */ + + if ( hh==ZVNULL || in==ZVNULL ) + error(E_NULL,"zhhtrvec"); + if ( in->dim != hh->dim ) + error(E_SIZES,"zhhtrvec"); + if ( i0 < 0 || i0 > in->dim ) + error(E_BOUNDS,"zhhvec"); + + tmp = _zin_prod(hh,in,i0,Z_CONJ); + scale.re = -beta*tmp.re; + scale.im = -beta*tmp.im; + out = zv_copy(in,out); + __zmltadd__(&(out->ve[i0]),&(hh->ve[i0]),scale, + (int)(in->dim-i0),Z_NOCONJ); + /************************************************************ + for ( i=i0; idim; i++ ) + out->ve[i] = in->ve[i] - scale*hh->ve[i]; + ************************************************************/ + + return (out); +} + +/* zhhtrrows -- transform a matrix by a Householder vector by rows + starting at row i0 from column j0 -- in-situ */ +ZMAT *zhhtrrows(M,i0,j0,hh,beta) +ZMAT *M; +int i0, j0; +ZVEC *hh; +double beta; +{ + complex ip, scale; + int i /*, j */; + + if ( M==ZMNULL || hh==ZVNULL ) + error(E_NULL,"zhhtrrows"); + if ( M->n != hh->dim ) + error(E_RANGE,"zhhtrrows"); + if ( i0 < 0 || i0 > M->m || j0 < 0 || j0 > M->n ) + error(E_BOUNDS,"zhhtrrows"); + + if ( beta == 0.0 ) return (M); + + /* for each row ... */ + for ( i = i0; i < M->m; i++ ) + { /* compute inner product */ + ip = __zip__(&(M->me[i][j0]),&(hh->ve[j0]), + (int)(M->n-j0),Z_NOCONJ); + /************************************************** + ip = 0.0; + for ( j = j0; j < M->n; j++ ) + ip += M->me[i][j]*hh->ve[j]; + **************************************************/ + scale.re = -beta*ip.re; + scale.im = -beta*ip.im; + /* if ( scale == 0.0 ) */ + if ( is_zero(scale) ) + continue; + + /* do operation */ + __zmltadd__(&(M->me[i][j0]),&(hh->ve[j0]),scale, + (int)(M->n-j0),Z_CONJ); + /************************************************** + for ( j = j0; j < M->n; j++ ) + M->me[i][j] -= scale*hh->ve[j]; + **************************************************/ + } + + return (M); +} + + +/* zhhtrcols -- transform a matrix by a Householder vector by columns + starting at row i0 from column j0 -- in-situ */ +ZMAT *zhhtrcols(M,i0,j0,hh,beta) +ZMAT *M; +int i0, j0; +ZVEC *hh; +double beta; +{ + /* Real ip, scale; */ + complex scale; + int i /*, k */; + static ZVEC *w = ZVNULL; + + if ( M==ZMNULL || hh==ZVNULL ) + error(E_NULL,"zhhtrcols"); + if ( M->m != hh->dim ) + error(E_SIZES,"zhhtrcols"); + if ( i0 < 0 || i0 > M->m || j0 < 0 || j0 > M->n ) + error(E_BOUNDS,"zhhtrcols"); + + if ( beta == 0.0 ) return (M); + + w = zv_resize(w,M->n); + MEM_STAT_REG(w,TYPE_ZVEC); + zv_zero(w); + + for ( i = i0; i < M->m; i++ ) + /* if ( hh->ve[i] != 0.0 ) */ + if ( ! is_zero(hh->ve[i]) ) + __zmltadd__(&(w->ve[j0]),&(M->me[i][j0]),hh->ve[i], + (int)(M->n-j0),Z_CONJ); + for ( i = i0; i < M->m; i++ ) + /* if ( hh->ve[i] != 0.0 ) */ + if ( ! is_zero(hh->ve[i]) ) + { + scale.re = -beta*hh->ve[i].re; + scale.im = -beta*hh->ve[i].im; + __zmltadd__(&(M->me[i][j0]),&(w->ve[j0]),scale, + (int)(M->n-j0),Z_CONJ); + } + return (M); +} + diff --git a/meschach/zlufctr.c b/meschach/zlufctr.c new file mode 100644 index 0000000..dbdb8a7 --- /dev/null +++ b/meschach/zlufctr.c @@ -0,0 +1,278 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + +/* + Matrix factorisation routines to work with the other matrix files. + Complex version +*/ + +static char rcsid[] = "$Id: zlufctr.c,v 1.1 2001/03/01 17:19:17 rfranke Exp $"; + +#include +#include +#include "zmatrix.h" +#include "zmatrix2.h" + +#define is_zero(z) ((z).re == 0.0 && (z).im == 0.0) + + +/* Most matrix factorisation routines are in-situ unless otherwise specified */ + +/* zLUfactor -- Gaussian elimination with scaled partial pivoting + -- Note: returns LU matrix which is A */ +ZMAT *zLUfactor(A,pivot) +ZMAT *A; +PERM *pivot; +{ + u_int i, j, k, k_max, m, n; + int i_max; + Real dtemp, max1; + complex **A_v, *A_piv, *A_row, temp; + static VEC *scale = VNULL; + + if ( A==ZMNULL || pivot==PNULL ) + error(E_NULL,"zLUfactor"); + if ( pivot->size != A->m ) + error(E_SIZES,"zLUfactor"); + m = A->m; n = A->n; + scale = v_resize(scale,A->m); + MEM_STAT_REG(scale,TYPE_VEC); + A_v = A->me; + + /* initialise pivot with identity permutation */ + for ( i=0; ipe[i] = i; + + /* set scale parameters */ + for ( i=0; ive[i] = max1; + } + + /* main loop */ + k_max = min(m,n)-1; + for ( k=0; kve[i] > 0.0 ) + { + dtemp = zabs(A_v[i][k])/scale->ve[i]; + if ( dtemp > max1 ) + { max1 = dtemp; i_max = i; } + } + + /* if no pivot then ignore column k... */ + if ( i_max == -1 ) + continue; + + /* do we pivot ? */ + if ( i_max != k ) /* yes we do... */ + { + px_transp(pivot,i_max,k); + for ( j=0; jm != A->n || A->n != b->dim ) + error(E_SIZES,"zLUsolve"); + + x = px_zvec(pivot,b,x); /* x := P.b */ + zLsolve(A,x,x,1.0); /* implicit diagonal = 1 */ + zUsolve(A,x,x,0.0); /* explicit diagonal */ + + return (x); +} + +/* zLUAsolve -- given an LU factorisation in A, solve A^*.x=b */ +ZVEC *zLUAsolve(LU,pivot,b,x) +ZMAT *LU; +PERM *pivot; +ZVEC *b,*x; +{ + if ( ! LU || ! b || ! pivot ) + error(E_NULL,"zLUAsolve"); + if ( LU->m != LU->n || LU->n != b->dim ) + error(E_SIZES,"zLUAsolve"); + + x = zv_copy(b,x); + zUAsolve(LU,x,x,0.0); /* explicit diagonal */ + zLAsolve(LU,x,x,1.0); /* implicit diagonal = 1 */ + pxinv_zvec(pivot,x,x); /* x := P^*.x */ + + return (x); +} + +/* zm_inverse -- returns inverse of A, provided A is not too rank deficient + -- uses LU factorisation */ +ZMAT *zm_inverse(A,out) +ZMAT *A, *out; +{ + int i; + ZVEC *tmp, *tmp2; + ZMAT *A_cp; + PERM *pivot; + + if ( ! A ) + error(E_NULL,"zm_inverse"); + if ( A->m != A->n ) + error(E_SQUARE,"zm_inverse"); + if ( ! out || out->m < A->m || out->n < A->n ) + out = zm_resize(out,A->m,A->n); + + A_cp = zm_copy(A,ZMNULL); + tmp = zv_get(A->m); + tmp2 = zv_get(A->m); + pivot = px_get(A->m); + tracecatch(zLUfactor(A_cp,pivot),"zm_inverse"); + for ( i = 0; i < A->n; i++ ) + { + zv_zero(tmp); + tmp->ve[i].re = 1.0; + tmp->ve[i].im = 0.0; + tracecatch(zLUsolve(A_cp,pivot,tmp,tmp2),"m_inverse"); + zset_col(out,i,tmp2); + } + + ZM_FREE(A_cp); + ZV_FREE(tmp); ZV_FREE(tmp2); + PX_FREE(pivot); + + return out; +} + +/* zLUcondest -- returns an estimate of the condition number of LU given the + LU factorisation in compact form */ +double zLUcondest(LU,pivot) +ZMAT *LU; +PERM *pivot; +{ + static ZVEC *y = ZVNULL, *z = ZVNULL; + Real cond_est, L_norm, U_norm, norm, sn_inv; + complex sum; + int i, j, n; + + if ( ! LU || ! pivot ) + error(E_NULL,"zLUcondest"); + if ( LU->m != LU->n ) + error(E_SQUARE,"zLUcondest"); + if ( LU->n != pivot->size ) + error(E_SIZES,"zLUcondest"); + + n = LU->n; + y = zv_resize(y,n); + z = zv_resize(z,n); + MEM_STAT_REG(y,TYPE_ZVEC); + MEM_STAT_REG(z,TYPE_ZVEC); + + cond_est = 0.0; /* should never be returned */ + + for ( i = 0; i < n; i++ ) + { + sum.re = 1.0; + sum.im = 0.0; + for ( j = 0; j < i; j++ ) + /* sum -= LU->me[j][i]*y->ve[j]; */ + sum = zsub(sum,zmlt(LU->me[j][i],y->ve[j])); + /* sum -= (sum < 0.0) ? 1.0 : -1.0; */ + sn_inv = 1.0 / zabs(sum); + sum.re += sum.re * sn_inv; + sum.im += sum.im * sn_inv; + if ( is_zero(LU->me[i][i]) ) + return HUGE; + /* y->ve[i] = sum / LU->me[i][i]; */ + y->ve[i] = zdiv(sum,LU->me[i][i]); + } + + zLAsolve(LU,y,y,1.0); + zLUsolve(LU,pivot,y,z); + + /* now estimate norm of A (even though it is not directly available) */ + /* actually computes ||L||_inf.||U||_inf */ + U_norm = 0.0; + for ( i = 0; i < n; i++ ) + { + norm = 0.0; + for ( j = i; j < n; j++ ) + norm += zabs(LU->me[i][j]); + if ( norm > U_norm ) + U_norm = norm; + } + L_norm = 0.0; + for ( i = 0; i < n; i++ ) + { + norm = 1.0; + for ( j = 0; j < i; j++ ) + norm += zabs(LU->me[i][j]); + if ( norm > L_norm ) + L_norm = norm; + } + + tracecatch(cond_est = U_norm*L_norm*zv_norm_inf(z)/zv_norm_inf(y), + "LUcondest"); + + return cond_est; +} diff --git a/meschach/zmachine.c b/meschach/zmachine.c new file mode 100644 index 0000000..a41f4f1 --- /dev/null +++ b/meschach/zmachine.c @@ -0,0 +1,174 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + This file contains basic routines which are used by the functions + involving complex vectors. + These are the routines that should be modified in order to take + full advantage of specialised architectures (pipelining, vector + processors etc). + */ +static char *rcsid = "$Id: zmachine.c,v 1.1 2001/03/01 17:19:17 rfranke Exp $"; + +#include +#include "machine.h" +#include "zmatrix.h" + + +/* __zconj__ -- complex conjugate */ +void __zconj__(zp,len) +complex *zp; +int len; +{ + int i; + + for ( i = 0; i < len; i++ ) + zp[i].im = - zp[i].im; +} + +/* __zip__ -- inner product + -- computes sum_i zp1[i].zp2[i] if flag == 0 + sum_i zp1[i]*.zp2[i] if flag != 0 */ +complex __zip__(zp1,zp2,len,flag) +complex *zp1, *zp2; +int flag, len; +{ + complex sum; + int i; + + sum.re = sum.im = 0.0; + if ( flag ) + { + for ( i = 0; i < len; i++ ) + { + sum.re += zp1[i].re*zp2[i].re + zp1[i].im*zp2[i].im; + sum.im += zp1[i].re*zp2[i].im - zp1[i].im*zp2[i].re; + } + } + else + { + for ( i = 0; i < len; i++ ) + { + sum.re += zp1[i].re*zp2[i].re - zp1[i].im*zp2[i].im; + sum.im += zp1[i].re*zp2[i].im + zp1[i].im*zp2[i].re; + } + } + + return sum; +} + +/* __zmltadd__ -- scalar multiply and add i.e. complex saxpy + -- computes zp1[i] += s.zp2[i] if flag == 0 + -- computes zp1[i] += s.zp2[i]* if flag != 0 */ +void __zmltadd__(zp1,zp2,s,len,flag) +complex *zp1, *zp2, s; +int flag, len; +{ + int i; + LongReal t_re, t_im; + + if ( ! flag ) + { + for ( i = 0; i < len; i++ ) + { + t_re = zp1[i].re + s.re*zp2[i].re - s.im*zp2[i].im; + t_im = zp1[i].im + s.re*zp2[i].im + s.im*zp2[i].re; + zp1[i].re = t_re; + zp1[i].im = t_im; + } + } + else + { + for ( i = 0; i < len; i++ ) + { + t_re = zp1[i].re + s.re*zp2[i].re + s.im*zp2[i].im; + t_im = zp1[i].im - s.re*zp2[i].im + s.im*zp2[i].re; + zp1[i].re = t_re; + zp1[i].im = t_im; + } + } +} + +/* __zmlt__ scalar complex multiply array c.f. sv_mlt() */ +void __zmlt__(zp,s,out,len) +complex *zp, s, *out; +register int len; +{ + int i; + LongReal t_re, t_im; + + for ( i = 0; i < len; i++ ) + { + t_re = s.re*zp[i].re - s.im*zp[i].im; + t_im = s.re*zp[i].im + s.im*zp[i].re; + out[i].re = t_re; + out[i].im = t_im; + } +} + +/* __zadd__ -- add complex arrays c.f. v_add() */ +void __zadd__(zp1,zp2,out,len) +complex *zp1, *zp2, *out; +int len; +{ + int i; + for ( i = 0; i < len; i++ ) + { + out[i].re = zp1[i].re + zp2[i].re; + out[i].im = zp1[i].im + zp2[i].im; + } +} + +/* __zsub__ -- subtract complex arrays c.f. v_sub() */ +void __zsub__(zp1,zp2,out,len) +complex *zp1, *zp2, *out; +int len; +{ + int i; + for ( i = 0; i < len; i++ ) + { + out[i].re = zp1[i].re - zp2[i].re; + out[i].im = zp1[i].im - zp2[i].im; + } +} + +/* __zzero__ -- zeros an array of complex numbers */ +void __zzero__(zp,len) +complex *zp; +int len; +{ + /* if a Real precision zero is equivalent to a string of nulls */ + MEM_ZERO((char *)zp,len*sizeof(complex)); + /* else, need to zero the array entry by entry */ + /****************************** + while ( len-- ) + { + zp->re = zp->im = 0.0; + zp++; + } + ******************************/ +} + diff --git a/meschach/zmatio.c b/meschach/zmatio.c new file mode 100644 index 0000000..1d566a3 --- /dev/null +++ b/meschach/zmatio.c @@ -0,0 +1,400 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + + +#include +#include +#include "zmatrix.h" + +static char rcsid[] = "$Id: zmatio.c,v 1.1 2001/03/01 17:19:18 rfranke Exp $"; + + + +/* local variables */ +static char line[MAXLINE]; + +/************************************************************************** + Input routines + **************************************************************************/ + +complex z_finput(fp) +FILE *fp; +{ + int io_code; + complex z; + + skipjunk(fp); + if ( isatty(fileno(fp)) ) + { + do { + fprintf(stderr,"real and imag parts: "); + if ( fgets(line,MAXLINE,fp) == NULL ) + error(E_EOF,"z_finput"); +#if REAL == DOUBLE + io_code = sscanf(line,"%lf%lf",&z.re,&z.im); +#elif REAL == FLOAT + io_code = sscanf(line,"%f%f",&z.re,&z.im); +#endif + + } while ( io_code != 2 ); + } + else +#if REAL == DOUBLE + if ( (io_code=fscanf(fp," (%lf,%lf)",&z.re,&z.im)) < 2 ) +#elif REAL == FLOAT + if ( (io_code=fscanf(fp," (%f,%f)",&z.re,&z.im)) < 2 ) +#endif + error((io_code == EOF) ? E_EOF : E_FORMAT,"z_finput"); + + return z; +} + + +ZMAT *zm_finput(fp,a) +FILE *fp; +ZMAT *a; +{ + ZMAT *izm_finput(),*bzm_finput(); + + if ( isatty(fileno(fp)) ) + return izm_finput(fp,a); + else + return bzm_finput(fp,a); +} + +/* izm_finput -- interactive input of matrix */ +ZMAT *izm_finput(fp,mat) +FILE *fp; +ZMAT *mat; +{ + char c; + u_int i, j, m, n, dynamic; + /* dynamic set to TRUE if memory allocated here */ + + /* get matrix size */ + if ( mat != ZMNULL && mat->mnm; n = mat->n; dynamic = FALSE; } + else + { + dynamic = TRUE; + do + { + fprintf(stderr,"ComplexMatrix: rows cols:"); + if ( fgets(line,MAXLINE,fp)==NULL ) + error(E_INPUT,"izm_finput"); + } while ( sscanf(line,"%u%u",&m,&n)<2 || m>MAXDIM || n>MAXDIM ); + mat = zm_get(m,n); + } + + /* input elements */ + for ( i=0; ime[i][j].re,mat->me[i][j].im); + if ( fgets(line,MAXLINE,fp)==NULL ) + error(E_INPUT,"izm_finput"); + if ( (*line == 'b' || *line == 'B') && j > 0 ) + { j--; dynamic = FALSE; goto redo2; } + if ( (*line == 'f' || *line == 'F') && j < n-1 ) + { j++; dynamic = FALSE; goto redo2; } + } while ( *line=='\0' || +#if REAL == DOUBLE + sscanf(line,"%lf%lf", +#elif REAL == FLOAT + sscanf(line,"%f%f", +#endif + &mat->me[i][j].re,&mat->me[i][j].im)<1 ); + fprintf(stderr,"Continue: "); + fscanf(fp,"%c",&c); + if ( c == 'n' || c == 'N' ) + { dynamic = FALSE; goto redo; } + if ( (c == 'b' || c == 'B') /* && i > 0 */ ) + { if ( i > 0 ) + i--; + dynamic = FALSE; goto redo; + } + } + + return (mat); +} + +/* bzm_finput -- batch-file input of matrix */ +ZMAT *bzm_finput(fp,mat) +FILE *fp; +ZMAT *mat; +{ + u_int i,j,m,n,dummy; + int io_code; + + /* get dimension */ + skipjunk(fp); + if ((io_code=fscanf(fp," ComplexMatrix: %u by %u",&m,&n)) < 2 || + m>MAXDIM || n>MAXDIM ) + error(io_code==EOF ? E_EOF : E_FORMAT,"bzm_finput"); + + /* allocate memory if necessary */ + if ( mat==ZMNULL || mat->mnme[i][j].re,&mat->me[i][j].im)) < 2 ) + error(io_code==EOF ? E_EOF : E_FORMAT,"bzm_finput"); + } + } + + return (mat); +} + +ZVEC *zv_finput(fp,x) +FILE *fp; +ZVEC *x; +{ + ZVEC *izv_finput(),*bzv_finput(); + + if ( isatty(fileno(fp)) ) + return izv_finput(fp,x); + else + return bzv_finput(fp,x); +} + +/* izv_finput -- interactive input of vector */ +ZVEC *izv_finput(fp,vec) +FILE *fp; +ZVEC *vec; +{ + u_int i,dim,dynamic; /* dynamic set if memory allocated here */ + + /* get vector dimension */ + if ( vec != ZVNULL && vec->dimdim; dynamic = FALSE; } + else + { + dynamic = TRUE; + do + { + fprintf(stderr,"ComplexVector: dim: "); + if ( fgets(line,MAXLINE,fp)==NULL ) + error(E_INPUT,"izv_finput"); + } while ( sscanf(line,"%u",&dim)<1 || dim>MAXDIM ); + vec = zv_get(dim); + } + + /* input elements */ + for ( i=0; ive[i].re,vec->ve[i].im); + if ( fgets(line,MAXLINE,fp)==NULL ) + error(E_INPUT,"izv_finput"); + if ( (*line == 'b' || *line == 'B') && i > 0 ) + { i--; dynamic = FALSE; goto redo; } + if ( (*line == 'f' || *line == 'F') && i < dim-1 ) + { i++; dynamic = FALSE; goto redo; } + } while ( *line=='\0' || +#if REAL == DOUBLE + sscanf(line,"%lf%lf", +#elif REAL == FLOAT + sscanf(line,"%f%f", +#endif + &vec->ve[i].re,&vec->ve[i].im) < 2 ); + + return (vec); +} + +/* bzv_finput -- batch-file input of vector */ +ZVEC *bzv_finput(fp,vec) +FILE *fp; +ZVEC *vec; +{ + u_int i,dim; + int io_code; + + /* get dimension */ + skipjunk(fp); + if ((io_code=fscanf(fp," ComplexVector: dim:%u",&dim)) < 1 || + dim>MAXDIM ) + error(io_code==EOF ? 7 : 6,"bzv_finput"); + + + /* allocate memory if necessary */ + if ( vec==ZVNULL || vec->dimve[i].re,&vec->ve[i].im)) < 2 ) + error(io_code==EOF ? 7 : 6,"bzv_finput"); + + return (vec); +} + +/************************************************************************** + Output routines + **************************************************************************/ +static char *zformat = " (%14.9g, %14.9g) "; + +char *setzformat(f_string) +char *f_string; +{ + char *old_f_string; + old_f_string = zformat; + if ( f_string != (char *)NULL && *f_string != '\0' ) + zformat = f_string; + + return old_f_string; +} + +void z_foutput(fp,z) +FILE *fp; +complex z; +{ + fprintf(fp,zformat,z.re,z.im); + putc('\n',fp); +} + +void zm_foutput(fp,a) +FILE *fp; +ZMAT *a; +{ + u_int i, j, tmp; + + if ( a == ZMNULL ) + { fprintf(fp,"ComplexMatrix: NULL\n"); return; } + fprintf(fp,"ComplexMatrix: %d by %d\n",a->m,a->n); + if ( a->me == (complex **)NULL ) + { fprintf(fp,"NULL\n"); return; } + for ( i=0; im; i++ ) /* for each row... */ + { + fprintf(fp,"row %u: ",i); + for ( j=0, tmp=1; jn; j++, tmp++ ) + { /* for each col in row... */ + fprintf(fp,zformat,a->me[i][j].re,a->me[i][j].im); + if ( ! (tmp % 2) ) putc('\n',fp); + } + if ( tmp % 2 != 1 ) putc('\n',fp); + } +} + +void zv_foutput(fp,x) +FILE *fp; +ZVEC *x; +{ + u_int i, tmp; + + if ( x == ZVNULL ) + { fprintf(fp,"ComplexVector: NULL\n"); return; } + fprintf(fp,"ComplexVector: dim: %d\n",x->dim); + if ( x->ve == (complex *)NULL ) + { fprintf(fp,"NULL\n"); return; } + for ( i=0, tmp=0; idim; i++, tmp++ ) + { + fprintf(fp,zformat,x->ve[i].re,x->ve[i].im); + if ( (tmp % 2) == 1 ) putc('\n',fp); + } + if ( (tmp % 2) != 0 ) putc('\n',fp); +} + + +void zm_dump(fp,a) +FILE *fp; +ZMAT *a; +{ + u_int i, j, tmp; + + if ( a == ZMNULL ) + { fprintf(fp,"ComplexMatrix: NULL\n"); return; } + fprintf(fp,"ComplexMatrix: %d by %d @ 0x%lx\n",a->m,a->n,(long)a); + fprintf(fp,"\tmax_m = %d, max_n = %d, max_size = %d\n", + a->max_m, a->max_n, a->max_size); + if ( a->me == (complex **)NULL ) + { fprintf(fp,"NULL\n"); return; } + fprintf(fp,"a->me @ 0x%lx\n",(long)(a->me)); + fprintf(fp,"a->base @ 0x%lx\n",(long)(a->base)); + for ( i=0; im; i++ ) /* for each row... */ + { + fprintf(fp,"row %u: @ 0x%lx ",i,(long)(a->me[i])); + for ( j=0, tmp=1; jn; j++, tmp++ ) + { /* for each col in row... */ + fprintf(fp,zformat,a->me[i][j].re,a->me[i][j].im); + if ( ! (tmp % 2) ) putc('\n',fp); + } + if ( tmp % 2 != 1 ) putc('\n',fp); + } +} + + + +void zv_dump(fp,x) +FILE *fp; +ZVEC *x; +{ + u_int i, tmp; + + if ( ! x ) + { fprintf(fp,"ComplexVector: NULL\n"); return; } + fprintf(fp,"ComplexVector: dim: %d @ 0x%lx\n",x->dim,(long)(x)); + if ( ! x->ve ) + { fprintf(fp,"NULL\n"); return; } + fprintf(fp,"x->ve @ 0x%lx\n",(long)(x->ve)); + for ( i=0, tmp=0; idim; i++, tmp++ ) + { + fprintf(fp,zformat,x->ve[i].re,x->ve[i].im); + if ( tmp % 2 == 1 ) putc('\n',fp); + } + if ( tmp % 2 != 0 ) putc('\n',fp); +} + diff --git a/meschach/zmatlab.c b/meschach/zmatlab.c new file mode 100644 index 0000000..b842883 --- /dev/null +++ b/meschach/zmatlab.c @@ -0,0 +1,214 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + This file contains routines for import/exporting complex data + to/from MATLAB. The main routines are: + ZMAT *zm_save(FILE *fp,ZMAT *A,char *name) + ZVEC *zv_save(FILE *fp,ZVEC *x,char *name) + complex z_save(FILE *fp,complex z,char *name) + ZMAT *zm_load(FILE *fp,char **name) +*/ + +#include +#include "zmatrix.h" +#include "matlab.h" + +static char rcsid[] = "$Id: zmatlab.c,v 1.1 2001/03/01 17:19:19 rfranke Exp $"; + +/* zm_save -- save matrix in ".mat" file for MATLAB + -- returns matrix to be saved */ +ZMAT *zm_save(fp,A,name) +FILE *fp; +ZMAT *A; +char *name; +{ + int i, j; + matlab mat; + + if ( ! A ) + error(E_NULL,"zm_save"); + + mat.type = 1000*MACH_ID + 100*ORDER + 10*PRECISION + 0; + mat.m = A->m; + mat.n = A->n; + mat.imag = TRUE; + mat.namlen = (name == (char *)NULL) ? 1 : strlen(name)+1; + + /* write header */ + fwrite(&mat,sizeof(matlab),1,fp); + /* write name */ + if ( name == (char *)NULL ) + fwrite("",sizeof(char),1,fp); + else + fwrite(name,sizeof(char),(int)(mat.namlen),fp); + /* write actual data */ + for ( i = 0; i < A->m; i++ ) + for ( j = 0; j < A->n; j++ ) + fwrite(&(A->me[i][j].re),sizeof(Real),1,fp); + for ( i = 0; i < A->m; i++ ) + for ( j = 0; j < A->n; j++ ) + fwrite(&(A->me[i][j].im),sizeof(Real),1,fp); + + return A; +} + + +/* zv_save -- save vector in ".mat" file for MATLAB + -- saves it as a row vector + -- returns vector to be saved */ +ZVEC *zv_save(fp,x,name) +FILE *fp; +ZVEC *x; +char *name; +{ + int i; + matlab mat; + + if ( ! x ) + error(E_NULL,"zv_save"); + + mat.type = 1000*MACH_ID + 100*ORDER + 10*PRECISION + 0; + mat.m = x->dim; + mat.n = 1; + mat.imag = TRUE; + mat.namlen = (name == (char *)NULL) ? 1 : strlen(name)+1; + + /* write header */ + fwrite(&mat,sizeof(matlab),1,fp); + /* write name */ + if ( name == (char *)NULL ) + fwrite("",sizeof(char),1,fp); + else + fwrite(name,sizeof(char),(int)(mat.namlen),fp); + /* write actual data */ + for ( i = 0; i < x->dim; i++ ) + fwrite(&(x->ve[i].re),sizeof(Real),1,fp); + for ( i = 0; i < x->dim; i++ ) + fwrite(&(x->ve[i].im),sizeof(Real),1,fp); + + return x; +} + +/* z_save -- saves complex number in ".mat" file for MATLAB + -- returns complex number to be saved */ +complex z_save(fp,z,name) +FILE *fp; +complex z; +char *name; +{ + matlab mat; + + mat.type = 1000*MACH_ID + 100*ORDER + 10*PRECISION + 0; + mat.m = 1; + mat.n = 1; + mat.imag = TRUE; + mat.namlen = (name == (char *)NULL) ? 1 : strlen(name)+1; + + /* write header */ + fwrite(&mat,sizeof(matlab),1,fp); + /* write name */ + if ( name == (char *)NULL ) + fwrite("",sizeof(char),1,fp); + else + fwrite(name,sizeof(char),(int)(mat.namlen),fp); + /* write actual data */ + fwrite(&z,sizeof(complex),1,fp); + + return z; +} + + + +/* zm_load -- loads in a ".mat" file variable as produced by MATLAB + -- matrix returned; imaginary parts ignored */ +ZMAT *zm_load(fp,name) +FILE *fp; +char **name; +{ + ZMAT *A; + int i; + int m_flag, o_flag, p_flag, t_flag; + float f_temp; + double d_temp; + matlab mat; + + if ( fread(&mat,sizeof(matlab),1,fp) != 1 ) + error(E_FORMAT,"zm_load"); + if ( mat.type >= 10000 ) /* don't load a sparse matrix! */ + error(E_FORMAT,"zm_load"); + m_flag = (mat.type/1000) % 10; + o_flag = (mat.type/100) % 10; + p_flag = (mat.type/10) % 10; + t_flag = (mat.type) % 10; + if ( m_flag != MACH_ID ) + error(E_FORMAT,"zm_load"); + if ( t_flag != 0 ) + error(E_FORMAT,"zm_load"); + if ( p_flag != DOUBLE_PREC && p_flag != SINGLE_PREC ) + error(E_FORMAT,"zm_load"); + *name = (char *)malloc((unsigned)(mat.namlen)+1); + if ( fread(*name,sizeof(char),(unsigned)(mat.namlen),fp) == 0 ) + error(E_FORMAT,"zm_load"); + A = zm_get((unsigned)(mat.m),(unsigned)(mat.n)); + for ( i = 0; i < A->m*A->n; i++ ) + { + if ( p_flag == DOUBLE_PREC ) + fread(&d_temp,sizeof(double),1,fp); + else + { + fread(&f_temp,sizeof(float),1,fp); + d_temp = f_temp; + } + if ( o_flag == ROW_ORDER ) + A->me[i / A->n][i % A->n].re = d_temp; + else if ( o_flag == COL_ORDER ) + A->me[i % A->m][i / A->m].re = d_temp; + else + error(E_FORMAT,"zm_load"); + } + + if ( mat.imag ) /* skip imaginary part */ + for ( i = 0; i < A->m*A->n; i++ ) + { + if ( p_flag == DOUBLE_PREC ) + fread(&d_temp,sizeof(double),1,fp); + else + { + fread(&f_temp,sizeof(float),1,fp); + d_temp = f_temp; + } + if ( o_flag == ROW_ORDER ) + A->me[i / A->n][i % A->n].im = d_temp; + else if ( o_flag == COL_ORDER ) + A->me[i % A->m][i / A->m].im = d_temp; + else + error(E_FORMAT,"zm_load"); + } + + return A; +} + diff --git a/meschach/zmatop.c b/meschach/zmatop.c new file mode 100644 index 0000000..81dcac2 --- /dev/null +++ b/meschach/zmatop.c @@ -0,0 +1,612 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + + +#include +#include "zmatrix.h" + +static char rcsid[] = "$Id: zmatop.c,v 1.1 2001/03/01 17:19:19 rfranke Exp $"; + + +#define is_zero(z) ((z).re == 0.0 && (z).im == 0.0) + +/* zm_add -- matrix addition -- may be in-situ */ +ZMAT *zm_add(mat1,mat2,out) +ZMAT *mat1,*mat2,*out; +{ + u_int m,n,i; + + if ( mat1==ZMNULL || mat2==ZMNULL ) + error(E_NULL,"zm_add"); + if ( mat1->m != mat2->m || mat1->n != mat2->n ) + error(E_SIZES,"zm_add"); + if ( out==ZMNULL || out->m != mat1->m || out->n != mat1->n ) + out = zm_resize(out,mat1->m,mat1->n); + m = mat1->m; n = mat1->n; + for ( i=0; ime[i],mat2->me[i],out->me[i],(int)n); + /************************************************** + for ( j=0; jme[i][j] = mat1->me[i][j]+mat2->me[i][j]; + **************************************************/ + } + + return (out); +} + +/* zm_sub -- matrix subtraction -- may be in-situ */ +ZMAT *zm_sub(mat1,mat2,out) +ZMAT *mat1,*mat2,*out; +{ + u_int m,n,i; + + if ( mat1==ZMNULL || mat2==ZMNULL ) + error(E_NULL,"zm_sub"); + if ( mat1->m != mat2->m || mat1->n != mat2->n ) + error(E_SIZES,"zm_sub"); + if ( out==ZMNULL || out->m != mat1->m || out->n != mat1->n ) + out = zm_resize(out,mat1->m,mat1->n); + m = mat1->m; n = mat1->n; + for ( i=0; ime[i],mat2->me[i],out->me[i],(int)n); + /************************************************** + for ( j=0; jme[i][j] = mat1->me[i][j]-mat2->me[i][j]; + **************************************************/ + } + + return (out); +} + +/* + Note: In the following routines, "adjoint" means complex conjugate + transpose: + A* = conjugate(A^T) + */ + +/* zm_mlt -- matrix-matrix multiplication */ +ZMAT *zm_mlt(A,B,OUT) +ZMAT *A,*B,*OUT; +{ + u_int i, /* j, */ k, m, n, p; + complex **A_v, **B_v /*, *B_row, *OUT_row, sum, tmp */; + + if ( A==ZMNULL || B==ZMNULL ) + error(E_NULL,"zm_mlt"); + if ( A->n != B->m ) + error(E_SIZES,"zm_mlt"); + if ( A == OUT || B == OUT ) + error(E_INSITU,"zm_mlt"); + m = A->m; n = A->n; p = B->n; + A_v = A->me; B_v = B->me; + + if ( OUT==ZMNULL || OUT->m != A->m || OUT->n != B->n ) + OUT = zm_resize(OUT,A->m,B->n); + + /**************************************************************** + for ( i=0; ime[i][j] = sum; + } + ****************************************************************/ + zm_zero(OUT); + for ( i=0; ime[i],B_v[k],A_v[i][k],(int)p,Z_NOCONJ); + /************************************************** + B_row = B_v[k]; OUT_row = OUT->me[i]; + for ( j=0; jn != B->n ) + error(E_SIZES,"zmma_mlt"); + if ( ! OUT || OUT->m != A->m || OUT->n != B->m ) + OUT = zm_resize(OUT,A->m,B->m); + + limit = A->n; + for ( i = 0; i < A->m; i++ ) + for ( j = 0; j < B->m; j++ ) + { + OUT->me[i][j] = __zip__(B->me[j],A->me[i],(int)limit,Z_CONJ); + /************************************************** + sum = 0.0; + A_row = A->me[i]; + B_row = B->me[j]; + for ( k = 0; k < limit; k++ ) + sum += (*A_row++)*(*B_row++); + OUT->me[i][j] = sum; + **************************************************/ + } + + return OUT; +} + +/* zmam_mlt -- matrix adjoint-matrix multiplication + -- A*.B is returned, result stored in OUT */ +ZMAT *zmam_mlt(A,B,OUT) +ZMAT *A, *B, *OUT; +{ + int i, k, limit; + /* complex *B_row, *OUT_row, multiplier; */ + complex tmp; + + if ( ! A || ! B ) + error(E_NULL,"zmam_mlt"); + if ( A == OUT || B == OUT ) + error(E_INSITU,"zmam_mlt"); + if ( A->m != B->m ) + error(E_SIZES,"zmam_mlt"); + if ( ! OUT || OUT->m != A->n || OUT->n != B->n ) + OUT = zm_resize(OUT,A->n,B->n); + + limit = B->n; + zm_zero(OUT); + for ( k = 0; k < A->m; k++ ) + for ( i = 0; i < A->n; i++ ) + { + tmp.re = A->me[k][i].re; + tmp.im = - A->me[k][i].im; + if ( ! is_zero(tmp) ) + __zmltadd__(OUT->me[i],B->me[k],tmp,(int)limit,Z_NOCONJ); + } + + return OUT; +} + +/* zmv_mlt -- matrix-vector multiplication + -- Note: b is treated as a column vector */ +ZVEC *zmv_mlt(A,b,out) +ZMAT *A; +ZVEC *b,*out; +{ + u_int i, m, n; + complex **A_v, *b_v /*, *A_row */; + /* register complex sum; */ + + if ( A==ZMNULL || b==ZVNULL ) + error(E_NULL,"zmv_mlt"); + if ( A->n != b->dim ) + error(E_SIZES,"zmv_mlt"); + if ( b == out ) + error(E_INSITU,"zmv_mlt"); + if ( out == ZVNULL || out->dim != A->m ) + out = zv_resize(out,A->m); + + m = A->m; n = A->n; + A_v = A->me; b_v = b->ve; + for ( i=0; ive[i] = __zip__(A_v[i],b_v,(int)n,Z_NOCONJ); + /************************************************** + A_row = A_v[i]; b_v = b->ve; + for ( j=0; jve[i] = sum; + **************************************************/ + } + + return out; +} + +/* zsm_mlt -- scalar-matrix multiply -- may be in-situ */ +ZMAT *zsm_mlt(scalar,matrix,out) +complex scalar; +ZMAT *matrix,*out; +{ + u_int m,n,i; + + if ( matrix==ZMNULL ) + error(E_NULL,"zsm_mlt"); + if ( out==ZMNULL || out->m != matrix->m || out->n != matrix->n ) + out = zm_resize(out,matrix->m,matrix->n); + m = matrix->m; n = matrix->n; + for ( i=0; ime[i],scalar,out->me[i],(int)n); + /************************************************** + for ( j=0; jme[i][j] = scalar*matrix->me[i][j]; + **************************************************/ + return (out); +} + +/* zvm_mlt -- vector adjoint-matrix multiplication */ +ZVEC *zvm_mlt(A,b,out) +ZMAT *A; +ZVEC *b,*out; +{ + u_int j,m,n; + /* complex sum,**A_v,*b_v; */ + + if ( A==ZMNULL || b==ZVNULL ) + error(E_NULL,"zvm_mlt"); + if ( A->m != b->dim ) + error(E_SIZES,"zvm_mlt"); + if ( b == out ) + error(E_INSITU,"zvm_mlt"); + if ( out == ZVNULL || out->dim != A->n ) + out = zv_resize(out,A->n); + + m = A->m; n = A->n; + + zv_zero(out); + for ( j = 0; j < m; j++ ) + if ( b->ve[j].re != 0.0 || b->ve[j].im != 0.0 ) + __zmltadd__(out->ve,A->me[j],b->ve[j],(int)n,Z_CONJ); + /************************************************** + A_v = A->me; b_v = b->ve; + for ( j=0; jve[j] = sum; + } + **************************************************/ + + return out; +} + +/* zm_adjoint -- adjoint matrix */ +ZMAT *zm_adjoint(in,out) +ZMAT *in, *out; +{ + int i, j; + int in_situ; + complex tmp; + + if ( in == ZMNULL ) + error(E_NULL,"zm_adjoint"); + if ( in == out && in->n != in->m ) + error(E_INSITU2,"zm_adjoint"); + in_situ = ( in == out ); + if ( out == ZMNULL || out->m != in->n || out->n != in->m ) + out = zm_resize(out,in->n,in->m); + + if ( ! in_situ ) + { + for ( i = 0; i < in->m; i++ ) + for ( j = 0; j < in->n; j++ ) + { + out->me[j][i].re = in->me[i][j].re; + out->me[j][i].im = - in->me[i][j].im; + } + } + else + { + for ( i = 0 ; i < in->m; i++ ) + { + for ( j = 0; j < i; j++ ) + { + tmp.re = in->me[i][j].re; + tmp.im = in->me[i][j].im; + in->me[i][j].re = in->me[j][i].re; + in->me[i][j].im = - in->me[j][i].im; + in->me[j][i].re = tmp.re; + in->me[j][i].im = - tmp.im; + } + in->me[i][i].im = - in->me[i][i].im; + } + } + + return out; +} + +/* zswap_rows -- swaps rows i and j of matrix A upto column lim */ +ZMAT *zswap_rows(A,i,j,lo,hi) +ZMAT *A; +int i, j, lo, hi; +{ + int k; + complex **A_me, tmp; + + if ( ! A ) + error(E_NULL,"swap_rows"); + if ( i < 0 || j < 0 || i >= A->m || j >= A->m ) + error(E_SIZES,"swap_rows"); + lo = max(0,lo); + hi = min(hi,A->n-1); + A_me = A->me; + + for ( k = lo; k <= hi; k++ ) + { + tmp = A_me[k][i]; + A_me[k][i] = A_me[k][j]; + A_me[k][j] = tmp; + } + return A; +} + +/* zswap_cols -- swap columns i and j of matrix A upto row lim */ +ZMAT *zswap_cols(A,i,j,lo,hi) +ZMAT *A; +int i, j, lo, hi; +{ + int k; + complex **A_me, tmp; + + if ( ! A ) + error(E_NULL,"swap_cols"); + if ( i < 0 || j < 0 || i >= A->n || j >= A->n ) + error(E_SIZES,"swap_cols"); + lo = max(0,lo); + hi = min(hi,A->m-1); + A_me = A->me; + + for ( k = lo; k <= hi; k++ ) + { + tmp = A_me[i][k]; + A_me[i][k] = A_me[j][k]; + A_me[j][k] = tmp; + } + return A; +} + +/* mz_mltadd -- matrix-scalar multiply and add + -- may be in situ + -- returns out == A1 + s*A2 */ +ZMAT *mz_mltadd(A1,A2,s,out) +ZMAT *A1, *A2, *out; +complex s; +{ + /* register complex *A1_e, *A2_e, *out_e; */ + /* register int j; */ + int i, m, n; + + if ( ! A1 || ! A2 ) + error(E_NULL,"mz_mltadd"); + if ( A1->m != A2->m || A1->n != A2->n ) + error(E_SIZES,"mz_mltadd"); + + if ( s.re == 0.0 && s.im == 0.0 ) + return zm_copy(A1,out); + if ( s.re == 1.0 && s.im == 0.0 ) + return zm_add(A1,A2,out); + + tracecatch(out = zm_copy(A1,out),"mz_mltadd"); + + m = A1->m; n = A1->n; + for ( i = 0; i < m; i++ ) + { + __zmltadd__(out->me[i],A2->me[i],s,(int)n,Z_NOCONJ); + /************************************************** + A1_e = A1->me[i]; + A2_e = A2->me[i]; + out_e = out->me[i]; + for ( j = 0; j < n; j++ ) + out_e[j] = A1_e[j] + s*A2_e[j]; + **************************************************/ + } + + return out; +} + +/* zmv_mltadd -- matrix-vector multiply and add + -- may not be in situ + -- returns out == v1 + alpha*A*v2 */ +ZVEC *zmv_mltadd(v1,v2,A,alpha,out) +ZVEC *v1, *v2, *out; +ZMAT *A; +complex alpha; +{ + /* register int j; */ + int i, m, n; + complex tmp, *v2_ve, *out_ve; + + if ( ! v1 || ! v2 || ! A ) + error(E_NULL,"zmv_mltadd"); + if ( out == v2 ) + error(E_INSITU,"zmv_mltadd"); + if ( v1->dim != A->m || v2->dim != A-> n ) + error(E_SIZES,"zmv_mltadd"); + + tracecatch(out = zv_copy(v1,out),"zmv_mltadd"); + + v2_ve = v2->ve; out_ve = out->ve; + m = A->m; n = A->n; + + if ( alpha.re == 0.0 && alpha.im == 0.0 ) + return out; + + for ( i = 0; i < m; i++ ) + { + tmp = __zip__(A->me[i],v2_ve,(int)n,Z_NOCONJ); + out_ve[i].re += alpha.re*tmp.re - alpha.im*tmp.im; + out_ve[i].im += alpha.re*tmp.im + alpha.im*tmp.re; + /************************************************** + A_e = A->me[i]; + sum = 0.0; + for ( j = 0; j < n; j++ ) + sum += A_e[j]*v2_ve[j]; + out_ve[i] = v1->ve[i] + alpha*sum; + **************************************************/ + } + + return out; +} + +/* zvm_mltadd -- vector-matrix multiply and add a la zvm_mlt() + -- may not be in situ + -- returns out == v1 + v2*.A */ +ZVEC *zvm_mltadd(v1,v2,A,alpha,out) +ZVEC *v1, *v2, *out; +ZMAT *A; +complex alpha; +{ + int /* i, */ j, m, n; + complex tmp, /* *A_e, */ *out_ve; + + if ( ! v1 || ! v2 || ! A ) + error(E_NULL,"zvm_mltadd"); + if ( v2 == out ) + error(E_INSITU,"zvm_mltadd"); + if ( v1->dim != A->n || A->m != v2->dim ) + error(E_SIZES,"zvm_mltadd"); + + tracecatch(out = zv_copy(v1,out),"zvm_mltadd"); + + out_ve = out->ve; m = A->m; n = A->n; + for ( j = 0; j < m; j++ ) + { + /* tmp = zmlt(v2->ve[j],alpha); */ + tmp.re = v2->ve[j].re*alpha.re - v2->ve[j].im*alpha.im; + tmp.im = v2->ve[j].re*alpha.im + v2->ve[j].im*alpha.re; + if ( tmp.re != 0.0 || tmp.im != 0.0 ) + __zmltadd__(out_ve,A->me[j],tmp,(int)n,Z_CONJ); + /************************************************** + A_e = A->me[j]; + for ( i = 0; i < n; i++ ) + out_ve[i] += A_e[i]*tmp; + **************************************************/ + } + + return out; +} + +/* zget_col -- gets a specified column of a matrix; returned as a vector */ +ZVEC *zget_col(mat,col,vec) +int col; +ZMAT *mat; +ZVEC *vec; +{ + u_int i; + + if ( mat==ZMNULL ) + error(E_NULL,"zget_col"); + if ( col < 0 || col >= mat->n ) + error(E_RANGE,"zget_col"); + if ( vec==ZVNULL || vec->dimm ) + vec = zv_resize(vec,mat->m); + + for ( i=0; im; i++ ) + vec->ve[i] = mat->me[i][col]; + + return (vec); +} + +/* zget_row -- gets a specified row of a matrix and retruns it as a vector */ +ZVEC *zget_row(mat,row,vec) +int row; +ZMAT *mat; +ZVEC *vec; +{ + int /* i, */ lim; + + if ( mat==ZMNULL ) + error(E_NULL,"zget_row"); + if ( row < 0 || row >= mat->m ) + error(E_RANGE,"zget_row"); + if ( vec==ZVNULL || vec->dimn ) + vec = zv_resize(vec,mat->n); + + lim = min(mat->n,vec->dim); + + /* for ( i=0; in; i++ ) */ + /* vec->ve[i] = mat->me[row][i]; */ + MEMCOPY(mat->me[row],vec->ve,lim,complex); + + return (vec); +} + +/* zset_col -- sets column of matrix to values given in vec (in situ) */ +ZMAT *zset_col(mat,col,vec) +ZMAT *mat; +ZVEC *vec; +int col; +{ + u_int i,lim; + + if ( mat==ZMNULL || vec==ZVNULL ) + error(E_NULL,"zset_col"); + if ( col < 0 || col >= mat->n ) + error(E_RANGE,"zset_col"); + lim = min(mat->m,vec->dim); + for ( i=0; ime[i][col] = vec->ve[i]; + + return (mat); +} + +/* zset_row -- sets row of matrix to values given in vec (in situ) */ +ZMAT *zset_row(mat,row,vec) +ZMAT *mat; +ZVEC *vec; +int row; +{ + u_int /* j, */ lim; + + if ( mat==ZMNULL || vec==ZVNULL ) + error(E_NULL,"zset_row"); + if ( row < 0 || row >= mat->m ) + error(E_RANGE,"zset_row"); + lim = min(mat->n,vec->dim); + /* for ( j=j0; jme[row][j] = vec->ve[j]; */ + MEMCOPY(vec->ve,mat->me[row],lim,complex); + + return (mat); +} + +/* zm_rand -- randomise a complex matrix; uniform in [0,1)+[0,1)*i */ +ZMAT *zm_rand(A) +ZMAT *A; +{ + int i; + + if ( ! A ) + error(E_NULL,"zm_rand"); + + for ( i = 0; i < A->m; i++ ) + mrandlist((Real *)(A->me[i]),2*A->n); + + return A; +} diff --git a/meschach/zmatrix.h b/meschach/zmatrix.h new file mode 100644 index 0000000..8eeef59 --- /dev/null +++ b/meschach/zmatrix.h @@ -0,0 +1,283 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* Main include file for zmeschach library -- complex vectors and matrices */ + +#ifndef ZMATRIXH +#define ZMATRIXH + +#include "matrix.h" + + + /* Type definitions for complex vectors and matrices */ + + +/* complex definition */ +typedef struct { + Real re,im; + } complex; + +/* complex vector definition */ +typedef struct { + u_int dim, max_dim; + complex *ve; + } ZVEC; + +/* complex matrix definition */ +typedef struct { + u_int m, n; + u_int max_m, max_n, max_size; + complex *base; /* base is base of alloc'd mem */ + complex **me; + } ZMAT; + +#define ZVNULL ((ZVEC *)NULL) +#define ZMNULL ((ZMAT *)NULL) + +#define Z_CONJ 1 +#define Z_NOCONJ 0 + + +/* memory functions */ + +#ifdef ANSI_C +int zv_get_vars(int dim,...); +int zm_get_vars(int m,int n,...); +int zv_resize_vars(int new_dim,...); +int zm_resize_vars(int m,int n,...); +int zv_free_vars(ZVEC **,...); +int zm_free_vars(ZMAT **,...); + +#elif VARARGS +int zv_get_vars(); +int zm_get_vars(); +int zv_resize_vars(); +int zm_resize_vars(); +int zv_free_vars(); +int zm_free_vars(); + +#endif + + + + +#ifdef ANSI_C +extern ZMAT *_zm_copy(ZMAT *in,ZMAT *out,u_int i0,u_int j0); +extern ZMAT * zm_move(ZMAT *, int, int, int, int, ZMAT *, int, int); +extern ZMAT *zvm_move(ZVEC *, int, ZMAT *, int, int, int, int); +extern ZVEC *_zv_copy(ZVEC *in,ZVEC *out,u_int i0); +extern ZVEC * zv_move(ZVEC *, int, int, ZVEC *, int); +extern ZVEC *zmv_move(ZMAT *, int, int, int, int, ZVEC *, int); +extern complex z_finput(FILE *fp); +extern ZMAT *zm_finput(FILE *fp,ZMAT *a); +extern ZVEC *zv_finput(FILE *fp,ZVEC *x); +extern ZMAT *zm_add(ZMAT *mat1,ZMAT *mat2,ZMAT *out); +extern ZMAT *zm_sub(ZMAT *mat1,ZMAT *mat2,ZMAT *out); +extern ZMAT *zm_mlt(ZMAT *A,ZMAT *B,ZMAT *OUT); +extern ZMAT *zmma_mlt(ZMAT *A,ZMAT *B,ZMAT *OUT); +extern ZMAT *zmam_mlt(ZMAT *A,ZMAT *B,ZMAT *OUT); +extern ZVEC *zmv_mlt(ZMAT *A,ZVEC *b,ZVEC *out); +extern ZMAT *zsm_mlt(complex scalar,ZMAT *matrix,ZMAT *out); +extern ZVEC *zvm_mlt(ZMAT *A,ZVEC *b,ZVEC *out); +extern ZMAT *zm_adjoint(ZMAT *in,ZMAT *out); +extern ZMAT *zswap_rows(ZMAT *A,int i,int j,int lo,int hi); +extern ZMAT *zswap_cols(ZMAT *A,int i,int j,int lo,int hi); +extern ZMAT *mz_mltadd(ZMAT *A1,ZMAT *A2,complex s,ZMAT *out); +extern ZVEC *zmv_mltadd(ZVEC *v1,ZVEC *v2,ZMAT *A,complex alpha,ZVEC *out); +extern ZVEC *zvm_mltadd(ZVEC *v1,ZVEC *v2,ZMAT *A,complex alpha,ZVEC *out); +extern ZVEC *zv_zero(ZVEC *x); +extern ZMAT *zm_zero(ZMAT *A); +extern ZMAT *zm_get(int m,int n); +extern ZVEC *zv_get(int dim); +extern ZMAT *zm_resize(ZMAT *A,int new_m,int new_n); +extern complex _zin_prod(ZVEC *x,ZVEC *y,u_int i0,u_int flag); +extern ZVEC *zv_resize(ZVEC *x,int new_dim); +extern ZVEC *zv_mlt(complex scalar,ZVEC *vector,ZVEC *out); +extern ZVEC *zv_add(ZVEC *vec1,ZVEC *vec2,ZVEC *out); +extern ZVEC *zv_mltadd(ZVEC *v1,ZVEC *v2,complex scale,ZVEC *out); +extern ZVEC *zv_sub(ZVEC *vec1,ZVEC *vec2,ZVEC *out); +#ifdef PROTOTYPES_IN_STRUCT +extern ZVEC *zv_map(complex (*f)(),ZVEC *x,ZVEC *out); +extern ZVEC *_zv_map(complex (*f)(),void *params,ZVEC *x,ZVEC *out); +#else +extern ZVEC *zv_map(complex (*f)(complex),ZVEC *x,ZVEC *out); +extern ZVEC *_zv_map(complex (*f)(void *,complex),void *params,ZVEC *x,ZVEC *out); +#endif +extern ZVEC *zv_lincomb(int n,ZVEC *v[],complex a[],ZVEC *out); +extern ZVEC *zv_linlist(ZVEC *out,ZVEC *v1,complex a1,...); +extern ZVEC *zv_star(ZVEC *x1, ZVEC *x2, ZVEC *out); +extern ZVEC *zv_slash(ZVEC *x1, ZVEC *x2, ZVEC *out); +extern int zm_free(ZMAT *mat); +extern int zv_free(ZVEC *vec); + +extern ZVEC *zv_rand(ZVEC *x); +extern ZMAT *zm_rand(ZMAT *A); + +extern ZVEC *zget_row(ZMAT *A, int i, ZVEC *out); +extern ZVEC *zget_col(ZMAT *A, int j, ZVEC *out); +extern ZMAT *zset_row(ZMAT *A, int i, ZVEC *in); +extern ZMAT *zset_col(ZMAT *A, int j, ZVEC *in); + +extern ZVEC *px_zvec(PERM *pi, ZVEC *in, ZVEC *out); +extern ZVEC *pxinv_zvec(PERM *pi, ZVEC *in, ZVEC *out); + +extern void __zconj__(complex zp[], int len); +extern complex __zip__(complex zp1[],complex zp2[],int len,int flag); +extern void __zmltadd__(complex zp1[],complex zp2[], + complex s,int len,int flag); +extern void __zmlt__(complex zp[],complex s,complex out[],int len); +extern void __zadd__(complex zp1[],complex zp2[],complex out[],int len); +extern void __zsub__(complex zp1[],complex zp2[],complex out[],int len); +extern void __zzero__(complex zp[],int len); +extern void z_foutput(FILE *fp,complex z); +extern void zm_foutput(FILE *fp,ZMAT *a); +extern void zv_foutput(FILE *fp,ZVEC *x); +extern void zm_dump(FILE *fp,ZMAT *a); +extern void zv_dump(FILE *fp,ZVEC *x); + +extern double _zv_norm1(ZVEC *x, VEC *scale); +extern double _zv_norm2(ZVEC *x, VEC *scale); +extern double _zv_norm_inf(ZVEC *x, VEC *scale); +extern double zm_norm1(ZMAT *A); +extern double zm_norm_inf(ZMAT *A); +extern double zm_norm_frob(ZMAT *A); + +complex zmake(double real, double imag); +double zabs(complex z); +complex zadd(complex z1,complex z2); +complex zsub(complex z1,complex z2); +complex zmlt(complex z1,complex z2); +complex zinv(complex z); +complex zdiv(complex z1,complex z2); +complex zsqrt(complex z); +complex zexp(complex z); +complex zlog(complex z); +complex zconj(complex z); +complex zneg(complex z); +#else +extern ZMAT *_zm_copy(); +extern ZVEC *_zv_copy(); +extern ZMAT *zm_finput(); +extern ZVEC *zv_finput(); +extern ZMAT *zm_add(); +extern ZMAT *zm_sub(); +extern ZMAT *zm_mlt(); +extern ZMAT *zmma_mlt(); +extern ZMAT *zmam_mlt(); +extern ZVEC *zmv_mlt(); +extern ZMAT *zsm_mlt(); +extern ZVEC *zvm_mlt(); +extern ZMAT *zm_adjoint(); +extern ZMAT *zswap_rows(); +extern ZMAT *zswap_cols(); +extern ZMAT *mz_mltadd(); +extern ZVEC *zmv_mltadd(); +extern ZVEC *zvm_mltadd(); +extern ZVEC *zv_zero(); +extern ZMAT *zm_zero(); +extern ZMAT *zm_get(); +extern ZVEC *zv_get(); +extern ZMAT *zm_resize(); +extern ZVEC *zv_resize(); +extern complex _zin_prod(); +extern ZVEC *zv_mlt(); +extern ZVEC *zv_add(); +extern ZVEC *zv_mltadd(); +extern ZVEC *zv_sub(); +extern ZVEC *zv_map(); +extern ZVEC *_zv_map(); +extern ZVEC *zv_lincomb(); +extern ZVEC *zv_linlist(); +extern ZVEC *zv_star(); +extern ZVEC *zv_slash(); + +extern ZVEC *px_zvec(); +extern ZVEC *pxinv_zvec(); + +extern ZVEC *zv_rand(); +extern ZMAT *zm_rand(); + +extern ZVEC *zget_row(); +extern ZVEC *zget_col(); +extern ZMAT *zset_row(); +extern ZMAT *zset_col(); + +extern int zm_free(); +extern int zv_free(); +extern void __zconj__(); +extern complex __zip__(); +extern void __zmltadd__(); +extern void __zmlt__(); +extern void __zadd__(); +extern void __zsub__(); +extern void __zzero__(); +extern void zm_foutput(); +extern void zv_foutput(); +extern void zm_dump(); +extern void zv_dump(); + +extern double _zv_norm1(); +extern double _zv_norm2(); +extern double _zv_norm_inf(); +extern double zm_norm1(); +extern double zm_norm_inf(); +extern double zm_norm_frob(); + +complex zmake(); +double zabs(); +complex zadd(); +complex zsub(); +complex zmlt(); +complex zinv(); +complex zdiv(); +complex zsqrt(); +complex zexp(); +complex zlog(); +complex zconj(); +complex zneg(); +#endif + +#define zv_copy(x,y) _zv_copy(x,y,0) +#define zm_copy(A,B) _zm_copy(A,B,0,0) + +#define z_input() z_finput(stdin) +#define zv_input(x) zv_finput(stdin,x) +#define zm_input(A) zm_finput(stdin,A) +#define z_output(z) z_foutput(stdout,z) +#define zv_output(x) zv_foutput(stdout,x) +#define zm_output(A) zm_foutput(stdout,A) + +#define ZV_FREE(x) ( zv_free(x), (x) = ZVNULL ) +#define ZM_FREE(A) ( zm_free(A), (A) = ZMNULL ) + +#define zin_prod(x,y) _zin_prod(x,y,0,Z_CONJ) + +#define zv_norm1(x) _zv_norm1(x,VNULL) +#define zv_norm2(x) _zv_norm2(x,VNULL) +#define zv_norm_inf(x) _zv_norm_inf(x,VNULL) + + +#endif diff --git a/meschach/zmatrix2.h b/meschach/zmatrix2.h new file mode 100644 index 0000000..cfe7334 --- /dev/null +++ b/meschach/zmatrix2.h @@ -0,0 +1,118 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + 2nd header file for Meschach's complex routines. + This file contains declarations for complex factorisation/solve + routines. + +*/ + + +#ifndef ZMATRIX2H +#define ZMATRIX2H + +#include "zmatrix.h" + +#ifdef ANSI_C +extern ZVEC *zUsolve(ZMAT *matrix, ZVEC *b, ZVEC *out, double diag); +extern ZVEC *zLsolve(ZMAT *matrix, ZVEC *b, ZVEC *out, double diag); +extern ZVEC *zUAsolve(ZMAT *U, ZVEC *b, ZVEC *out, double diag); +extern ZVEC *zDsolve(ZMAT *A, ZVEC *b, ZVEC *x); +extern ZVEC *zLAsolve(ZMAT *L, ZVEC *b, ZVEC *out, double diag); + +extern ZVEC *zhhvec(ZVEC *,int,Real *,ZVEC *,complex *); +extern ZVEC *zhhtrvec(ZVEC *,double,int,ZVEC *,ZVEC *); +extern ZMAT *zhhtrrows(ZMAT *,int,int,ZVEC *,double); +extern ZMAT *zhhtrcols(ZMAT *,int,int,ZVEC *,double); +extern ZMAT *zHfactor(ZMAT *,ZVEC *); +extern ZMAT *zHQunpack(ZMAT *,ZVEC *,ZMAT *,ZMAT *); + +extern ZMAT *zQRfactor(ZMAT *A, ZVEC *diag); +extern ZMAT *zQRCPfactor(ZMAT *A, ZVEC *diag, PERM *px); +extern ZVEC *_zQsolve(ZMAT *QR, ZVEC *diag, ZVEC *b, ZVEC *x, ZVEC *tmp); +extern ZMAT *zmakeQ(ZMAT *QR, ZVEC *diag, ZMAT *Qout); +extern ZMAT *zmakeR(ZMAT *QR, ZMAT *Rout); +extern ZVEC *zQRsolve(ZMAT *QR, ZVEC *diag, ZVEC *b, ZVEC *x); +extern ZVEC *zQRAsolve(ZMAT *QR, ZVEC *diag, ZVEC *b, ZVEC *x); +extern ZVEC *zQRCPsolve(ZMAT *QR,ZVEC *diag,PERM *pivot,ZVEC *b,ZVEC *x); +extern ZVEC *zUmlt(ZMAT *U, ZVEC *x, ZVEC *out); +extern ZVEC *zUAmlt(ZMAT *U, ZVEC *x, ZVEC *out); +extern double zQRcondest(ZMAT *QR); + +extern ZVEC *zLsolve(ZMAT *, ZVEC *, ZVEC *, double); +extern ZMAT *zset_col(ZMAT *, int, ZVEC *); + +extern ZMAT *zLUfactor(ZMAT *A, PERM *pivot); +extern ZVEC *zLUsolve(ZMAT *A, PERM *pivot, ZVEC *b, ZVEC *x); +extern ZVEC *zLUAsolve(ZMAT *LU, PERM *pivot, ZVEC *b, ZVEC *x); +extern ZMAT *zm_inverse(ZMAT *A, ZMAT *out); +extern double zLUcondest(ZMAT *LU, PERM *pivot); + +extern void zgivens(complex, complex, Real *, complex *); +extern ZMAT *zrot_rows(ZMAT *A, int i, int k, double c, complex s, + ZMAT *out); +extern ZMAT *zrot_cols(ZMAT *A, int i, int k, double c, complex s, + ZMAT *out); +extern ZVEC *rot_zvec(ZVEC *x, int i, int k, double c, complex s, + ZVEC *out); +extern ZMAT *zschur(ZMAT *A,ZMAT *Q); +/* extern ZMAT *schur_vecs(ZMAT *T,ZMAT *Q,X_re,X_im) */ +#else +extern ZVEC *zUsolve(), *zLsolve(), *zUAsolve(), *zDsolve(), *zLAsolve(); + +extern ZVEC *zhhvec(); +extern ZVEC *zhhtrvec(); +extern ZMAT *zhhtrrows(); +extern ZMAT *zhhtrcols(); +extern ZMAT *zHfactor(); +extern ZMAT *zHQunpack(); + + +extern ZMAT *zQRfactor(), *zQRCPfactor(); +extern ZVEC *_zQsolve(); +extern ZMAT *zmakeQ(), *zmakeR(); +extern ZVEC *zQRsolve(), *zQRAsolve(), *zQRCPsolve(); +extern ZVEC *zUmlt(), *zUAmlt(); +extern double zQRcondest(); + +extern ZVEC *zLsolve(); +extern ZMAT *zset_col(); + +extern ZMAT *zLUfactor(); +extern ZVEC *zLUsolve(), *zLUAsolve(); +extern ZMAT *zm_inverse(); +extern double zLUcondest(); + +extern void zgivens(); +extern ZMAT *zrot_rows(), *zrot_cols(); +extern ZVEC *rot_zvec(); +extern ZMAT *zschur(); +/* extern ZMAT *schur_vecs(); */ +#endif + +#endif + diff --git a/meschach/zmemory.c b/meschach/zmemory.c new file mode 100644 index 0000000..c93aceb --- /dev/null +++ b/meschach/zmemory.c @@ -0,0 +1,713 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* Memory allocation and de-allocation for complex matrices and vectors */ + +#include +#include "zmatrix.h" + +static char rcsid[] = "$Id: zmemory.c,v 1.1 2001/03/01 17:19:21 rfranke Exp $"; + + + +/* zv_zero -- zeros all entries of a complex vector + -- uses __zzero__() */ +ZVEC *zv_zero(x) +ZVEC *x; +{ + if ( ! x ) + error(E_NULL,"zv_zero"); + __zzero__(x->ve,x->dim); + + return x; +} + +/* zm_zero -- zeros all entries of a complex matrix + -- uses __zzero__() */ +ZMAT *zm_zero(A) +ZMAT *A; +{ + int i; + + if ( ! A ) + error(E_NULL,"zm_zero"); + for ( i = 0; i < A->m; i++ ) + __zzero__(A->me[i],A->n); + + return A; +} + +/* zm_get -- gets an mxn complex matrix (in ZMAT form) */ +ZMAT *zm_get(m,n) +int m,n; +{ + ZMAT *matrix; + u_int i; + + if (m < 0 || n < 0) + error(E_NEG,"zm_get"); + + if ((matrix=NEW(ZMAT)) == (ZMAT *)NULL ) + error(E_MEM,"zm_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_ZMAT,0,sizeof(ZMAT)); + mem_numvar(TYPE_ZMAT,1); + } + + matrix->m = m; matrix->n = matrix->max_n = n; + matrix->max_m = m; matrix->max_size = m*n; +#ifndef SEGMENTED + if ((matrix->base = NEW_A(m*n,complex)) == (complex *)NULL ) + { + free(matrix); + error(E_MEM,"zm_get"); + } + else if (mem_info_is_on()) { + mem_bytes(TYPE_ZMAT,0,m*n*sizeof(complex)); + } +#else + matrix->base = (complex *)NULL; +#endif + if ((matrix->me = (complex **)calloc(m,sizeof(complex *))) == + (complex **)NULL ) + { free(matrix->base); free(matrix); + error(E_MEM,"zm_get"); + } + else if (mem_info_is_on()) { + mem_bytes(TYPE_ZMAT,0,m*sizeof(complex *)); + } +#ifndef SEGMENTED + /* set up pointers */ + for ( i=0; ime[i] = &(matrix->base[i*n]); +#else + for ( i = 0; i < m; i++ ) + if ( (matrix->me[i]=NEW_A(n,complex)) == (complex *)NULL ) + error(E_MEM,"zm_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_ZMAT,0,n*sizeof(complex)); + } +#endif + + return (matrix); +} + + +/* zv_get -- gets a ZVEC of dimension 'dim' + -- Note: initialized to zero */ +ZVEC *zv_get(size) +int size; +{ + ZVEC *vector; + + if (size < 0) + error(E_NEG,"zv_get"); + + if ((vector=NEW(ZVEC)) == (ZVEC *)NULL ) + error(E_MEM,"zv_get"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_ZVEC,0,sizeof(ZVEC)); + mem_numvar(TYPE_ZVEC,1); + } + vector->dim = vector->max_dim = size; + if ((vector->ve=NEW_A(size,complex)) == (complex *)NULL ) + { + free(vector); + error(E_MEM,"zv_get"); + } + else if (mem_info_is_on()) { + mem_bytes(TYPE_ZVEC,0,size*sizeof(complex)); + } + return (vector); +} + +/* zm_free -- returns ZMAT & asoociated memory back to memory heap */ +int zm_free(mat) +ZMAT *mat; +{ +#ifdef SEGMENTED + int i; +#endif + + if ( mat==(ZMAT *)NULL || (int)(mat->m) < 0 || + (int)(mat->n) < 0 ) + /* don't trust it */ + return (-1); + +#ifndef SEGMENTED + if ( mat->base != (complex *)NULL ) { + if (mem_info_is_on()) { + mem_bytes(TYPE_ZMAT,mat->max_m*mat->max_n*sizeof(complex),0); + } + free((char *)(mat->base)); + } +#else + for ( i = 0; i < mat->max_m; i++ ) + if ( mat->me[i] != (complex *)NULL ) { + if (mem_info_is_on()) { + mem_bytes(TYPE_ZMAT,mat->max_n*sizeof(complex),0); + } + free((char *)(mat->me[i])); + } +#endif + if ( mat->me != (complex **)NULL ) { + if (mem_info_is_on()) { + mem_bytes(TYPE_ZMAT,mat->max_m*sizeof(complex *),0); + } + free((char *)(mat->me)); + } + + if (mem_info_is_on()) { + mem_bytes(TYPE_ZMAT,sizeof(ZMAT),0); + mem_numvar(TYPE_ZMAT,-1); + } + free((char *)mat); + + return (0); +} + + +/* zv_free -- returns ZVEC & asoociated memory back to memory heap */ +int zv_free(vec) +ZVEC *vec; +{ + if ( vec==(ZVEC *)NULL || (int)(vec->dim) < 0 ) + /* don't trust it */ + return (-1); + + if ( vec->ve == (complex *)NULL ) { + if (mem_info_is_on()) { + mem_bytes(TYPE_ZVEC,sizeof(ZVEC),0); + mem_numvar(TYPE_ZVEC,-1); + } + free((char *)vec); + } + else + { + if (mem_info_is_on()) { + mem_bytes(TYPE_ZVEC,vec->max_dim*sizeof(complex)+ + sizeof(ZVEC),0); + mem_numvar(TYPE_ZVEC,-1); + } + + free((char *)vec->ve); + free((char *)vec); + } + + return (0); +} + + +/* zm_resize -- returns the matrix A of size new_m x new_n; A is zeroed + -- if A == NULL on entry then the effect is equivalent to m_get() */ +ZMAT *zm_resize(A,new_m,new_n) +ZMAT *A; +int new_m, new_n; +{ + u_int i, new_max_m, new_max_n, new_size, old_m, old_n; + + if (new_m < 0 || new_n < 0) + error(E_NEG,"zm_resize"); + + if ( ! A ) + return zm_get(new_m,new_n); + + if (new_m == A->m && new_n == A->n) + return A; + + old_m = A->m; old_n = A->n; + if ( new_m > A->max_m ) + { /* re-allocate A->me */ + if (mem_info_is_on()) { + mem_bytes(TYPE_ZMAT,A->max_m*sizeof(complex *), + new_m*sizeof(complex *)); + } + + A->me = RENEW(A->me,new_m,complex *); + if ( ! A->me ) + error(E_MEM,"zm_resize"); + } + new_max_m = max(new_m,A->max_m); + new_max_n = max(new_n,A->max_n); + +#ifndef SEGMENTED + new_size = new_max_m*new_max_n; + if ( new_size > A->max_size ) + { /* re-allocate A->base */ + if (mem_info_is_on()) { + mem_bytes(TYPE_ZMAT,A->max_m*A->max_n*sizeof(complex), + new_size*sizeof(complex)); + } + + A->base = RENEW(A->base,new_size,complex); + if ( ! A->base ) + error(E_MEM,"zm_resize"); + A->max_size = new_size; + } + + /* now set up A->me[i] */ + for ( i = 0; i < new_m; i++ ) + A->me[i] = &(A->base[i*new_n]); + + /* now shift data in matrix */ + if ( old_n > new_n ) + { + for ( i = 1; i < min(old_m,new_m); i++ ) + MEM_COPY((char *)&(A->base[i*old_n]), + (char *)&(A->base[i*new_n]), + sizeof(complex)*new_n); + } + else if ( old_n < new_n ) + { + for ( i = min(old_m,new_m)-1; i > 0; i-- ) + { /* copy & then zero extra space */ + MEM_COPY((char *)&(A->base[i*old_n]), + (char *)&(A->base[i*new_n]), + sizeof(complex)*old_n); + __zzero__(&(A->base[i*new_n+old_n]),(new_n-old_n)); + } + __zzero__(&(A->base[old_n]),(new_n-old_n)); + A->max_n = new_n; + } + /* zero out the new rows.. */ + for ( i = old_m; i < new_m; i++ ) + __zzero__(&(A->base[i*new_n]),new_n); +#else + if ( A->max_n < new_n ) + { + complex *tmp; + + for ( i = 0; i < A->max_m; i++ ) + { + if (mem_info_is_on()) { + mem_bytes(TYPE_ZMAT,A->max_n*sizeof(complex), + new_max_n*sizeof(complex)); + } + + if ( (tmp = RENEW(A->me[i],new_max_n,complex)) == NULL ) + error(E_MEM,"zm_resize"); + else { + A->me[i] = tmp; + } + } + for ( i = A->max_m; i < new_max_m; i++ ) + { + if ( (tmp = NEW_A(new_max_n,complex)) == NULL ) + error(E_MEM,"zm_resize"); + else { + A->me[i] = tmp; + if (mem_info_is_on()) { + mem_bytes(TYPE_ZMAT,0,new_max_n*sizeof(complex)); + } + } + } + } + else if ( A->max_m < new_m ) + { + for ( i = A->max_m; i < new_m; i++ ) + if ( (A->me[i] = NEW_A(new_max_n,complex)) == NULL ) + error(E_MEM,"zm_resize"); + else if (mem_info_is_on()) { + mem_bytes(TYPE_ZMAT,0,new_max*sizeof(complex)); + } + + } + + if ( old_n < new_n ) + { + for ( i = 0; i < old_m; i++ ) + __zzero__(&(A->me[i][old_n]),new_n-old_n); + } + + /* zero out the new rows.. */ + for ( i = old_m; i < new_m; i++ ) + __zzero__(A->me[i],new_n); +#endif + + A->max_m = new_max_m; + A->max_n = new_max_n; + A->max_size = A->max_m*A->max_n; + A->m = new_m; A->n = new_n; + + return A; +} + + +/* zv_resize -- returns the (complex) vector x with dim new_dim + -- x is set to the zero vector */ +ZVEC *zv_resize(x,new_dim) +ZVEC *x; +int new_dim; +{ + if (new_dim < 0) + error(E_NEG,"zv_resize"); + + if ( ! x ) + return zv_get(new_dim); + + if (new_dim == x->dim) + return x; + + if ( x->max_dim == 0 ) /* assume that it's from sub_zvec */ + return zv_get(new_dim); + + if ( new_dim > x->max_dim ) + { + if (mem_info_is_on()) { + mem_bytes(TYPE_ZVEC,x->max_dim*sizeof(complex), + new_dim*sizeof(complex)); + } + + x->ve = RENEW(x->ve,new_dim,complex); + if ( ! x->ve ) + error(E_MEM,"zv_resize"); + x->max_dim = new_dim; + } + + if ( new_dim > x->dim ) + __zzero__(&(x->ve[x->dim]),new_dim - x->dim); + x->dim = new_dim; + + return x; +} + + +/* varying arguments */ + +#ifdef ANSI_C + +#include + + +/* To allocate memory to many arguments. + The function should be called: + zv_get_vars(dim,&x,&y,&z,...,NULL); + where + int dim; + ZVEC *x, *y, *z,...; + The last argument should be NULL ! + dim is the length of vectors x,y,z,... + returned value is equal to the number of allocated variables + Other gec_... functions are similar. +*/ + +int zv_get_vars(int dim,...) +{ + va_list ap; + int i=0; + ZVEC **par; + + va_start(ap, dim); + while (par = va_arg(ap,ZVEC **)) { /* NULL ends the list*/ + *par = zv_get(dim); + i++; + } + + va_end(ap); + return i; +} + + + +int zm_get_vars(int m,int n,...) +{ + va_list ap; + int i=0; + ZMAT **par; + + va_start(ap, n); + while (par = va_arg(ap,ZMAT **)) { /* NULL ends the list*/ + *par = zm_get(m,n); + i++; + } + + va_end(ap); + return i; +} + + + +/* To resize memory for many arguments. + The function should be called: + v_resize_vars(new_dim,&x,&y,&z,...,NULL); + where + int new_dim; + ZVEC *x, *y, *z,...; + The last argument should be NULL ! + rdim is the resized length of vectors x,y,z,... + returned value is equal to the number of allocated variables. + If one of x,y,z,.. arguments is NULL then memory is allocated to this + argument. + Other *_resize_list() functions are similar. +*/ + +int zv_resize_vars(int new_dim,...) +{ + va_list ap; + int i=0; + ZVEC **par; + + va_start(ap, new_dim); + while (par = va_arg(ap,ZVEC **)) { /* NULL ends the list*/ + *par = zv_resize(*par,new_dim); + i++; + } + + va_end(ap); + return i; +} + + + +int zm_resize_vars(int m,int n,...) +{ + va_list ap; + int i=0; + ZMAT **par; + + va_start(ap, n); + while (par = va_arg(ap,ZMAT **)) { /* NULL ends the list*/ + *par = zm_resize(*par,m,n); + i++; + } + + va_end(ap); + return i; +} + + +/* To deallocate memory for many arguments. + The function should be called: + v_free_vars(&x,&y,&z,...,NULL); + where + ZVEC *x, *y, *z,...; + The last argument should be NULL ! + There must be at least one not NULL argument. + returned value is equal to the number of allocated variables. + Returned value of x,y,z,.. is VNULL. + Other *_free_list() functions are similar. +*/ + +int zv_free_vars(ZVEC **pv,...) +{ + va_list ap; + int i=1; + ZVEC **par; + + zv_free(*pv); + *pv = ZVNULL; + va_start(ap, pv); + while (par = va_arg(ap,ZVEC **)) { /* NULL ends the list*/ + zv_free(*par); + *par = ZVNULL; + i++; + } + + va_end(ap); + return i; +} + + + +int zm_free_vars(ZMAT **va,...) +{ + va_list ap; + int i=1; + ZMAT **par; + + zm_free(*va); + *va = ZMNULL; + va_start(ap, va); + while (par = va_arg(ap,ZMAT **)) { /* NULL ends the list*/ + zm_free(*par); + *par = ZMNULL; + i++; + } + + va_end(ap); + return i; +} + + + +#elif VARARGS + +#include + +/* To allocate memory to many arguments. + The function should be called: + v_get_vars(dim,&x,&y,&z,...,NULL); + where + int dim; + ZVEC *x, *y, *z,...; + The last argument should be NULL ! + dim is the length of vectors x,y,z,... + returned value is equal to the number of allocated variables + Other gec_... functions are similar. +*/ + +int zv_get_vars(va_alist) va_dcl +{ + va_list ap; + int dim,i=0; + ZVEC **par; + + va_start(ap); + dim = va_arg(ap,int); + while (par = va_arg(ap,ZVEC **)) { /* NULL ends the list*/ + *par = zv_get(dim); + i++; + } + + va_end(ap); + return i; +} + + + +int zm_get_vars(va_alist) va_dcl +{ + va_list ap; + int i=0, n, m; + ZMAT **par; + + va_start(ap); + m = va_arg(ap,int); + n = va_arg(ap,int); + while (par = va_arg(ap,ZMAT **)) { /* NULL ends the list*/ + *par = zm_get(m,n); + i++; + } + + va_end(ap); + return i; +} + + + +/* To resize memory for many arguments. + The function should be called: + v_resize_vars(new_dim,&x,&y,&z,...,NULL); + where + int new_dim; + ZVEC *x, *y, *z,...; + The last argument should be NULL ! + rdim is the resized length of vectors x,y,z,... + returned value is equal to the number of allocated variables. + If one of x,y,z,.. arguments is NULL then memory is allocated to this + argument. + Other *_resize_list() functions are similar. +*/ + +int zv_resize_vars(va_alist) va_dcl +{ + va_list ap; + int i=0, new_dim; + ZVEC **par; + + va_start(ap); + new_dim = va_arg(ap,int); + while (par = va_arg(ap,ZVEC **)) { /* NULL ends the list*/ + *par = zv_resize(*par,new_dim); + i++; + } + + va_end(ap); + return i; +} + + +int zm_resize_vars(va_alist) va_dcl +{ + va_list ap; + int i=0, m, n; + ZMAT **par; + + va_start(ap); + m = va_arg(ap,int); + n = va_arg(ap,int); + while (par = va_arg(ap,ZMAT **)) { /* NULL ends the list*/ + *par = zm_resize(*par,m,n); + i++; + } + + va_end(ap); + return i; +} + + + +/* To deallocate memory for many arguments. + The function should be called: + v_free_vars(&x,&y,&z,...,NULL); + where + ZVEC *x, *y, *z,...; + The last argument should be NULL ! + There must be at least one not NULL argument. + returned value is equal to the number of allocated variables. + Returned value of x,y,z,.. is VNULL. + Other *_free_list() functions are similar. +*/ + +int zv_free_vars(va_alist) va_dcl +{ + va_list ap; + int i=0; + ZVEC **par; + + va_start(ap); + while (par = va_arg(ap,ZVEC **)) { /* NULL ends the list*/ + zv_free(*par); + *par = ZVNULL; + i++; + } + + va_end(ap); + return i; +} + + + +int zm_free_vars(va_alist) va_dcl +{ + va_list ap; + int i=0; + ZMAT **par; + + va_start(ap); + while (par = va_arg(ap,ZMAT **)) { /* NULL ends the list*/ + zm_free(*par); + *par = ZMNULL; + i++; + } + + va_end(ap); + return i; +} + + +#endif + diff --git a/meschach/znorm.c b/meschach/znorm.c new file mode 100644 index 0000000..6981827 --- /dev/null +++ b/meschach/znorm.c @@ -0,0 +1,208 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + A collection of functions for computing norms: scaled and unscaled + Complex version +*/ +static char rcsid[] = "$Id: znorm.c,v 1.1 2001/03/01 17:19:21 rfranke Exp $"; + +#include +#include +#include "zmatrix.h" + + + +/* _zv_norm1 -- computes (scaled) 1-norms of vectors */ +double _zv_norm1(x,scale) +ZVEC *x; +VEC *scale; +{ + int i, dim; + Real s, sum; + + if ( x == ZVNULL ) + error(E_NULL,"_zv_norm1"); + dim = x->dim; + + sum = 0.0; + if ( scale == VNULL ) + for ( i = 0; i < dim; i++ ) + sum += zabs(x->ve[i]); + else if ( scale->dim < dim ) + error(E_SIZES,"_zv_norm1"); + else + for ( i = 0; i < dim; i++ ) + { + s = scale->ve[i]; + sum += ( s== 0.0 ) ? zabs(x->ve[i]) : zabs(x->ve[i])/fabs(s); + } + + return sum; +} + +/* square -- returns x^2 */ +/****************************** +double square(x) +double x; +{ return x*x; } +******************************/ + +#define square(x) ((x)*(x)) + +/* _zv_norm2 -- computes (scaled) 2-norm (Euclidean norm) of vectors */ +double _zv_norm2(x,scale) +ZVEC *x; +VEC *scale; +{ + int i, dim; + Real s, sum; + + if ( x == ZVNULL ) + error(E_NULL,"_zv_norm2"); + dim = x->dim; + + sum = 0.0; + if ( scale == VNULL ) + for ( i = 0; i < dim; i++ ) + sum += square(x->ve[i].re) + square(x->ve[i].im); + else if ( scale->dim < dim ) + error(E_SIZES,"_v_norm2"); + else + for ( i = 0; i < dim; i++ ) + { + s = scale->ve[i]; + sum += ( s== 0.0 ) ? square(x->ve[i].re) + square(x->ve[i].im) : + (square(x->ve[i].re) + square(x->ve[i].im))/square(s); + } + + return sqrt(sum); +} + +#define max(a,b) ((a) > (b) ? (a) : (b)) + +/* _zv_norm_inf -- computes (scaled) infinity-norm (supremum norm) of vectors */ +double _zv_norm_inf(x,scale) +ZVEC *x; +VEC *scale; +{ + int i, dim; + Real s, maxval, tmp; + + if ( x == ZVNULL ) + error(E_NULL,"_zv_norm_inf"); + dim = x->dim; + + maxval = 0.0; + if ( scale == VNULL ) + for ( i = 0; i < dim; i++ ) + { + tmp = zabs(x->ve[i]); + maxval = max(maxval,tmp); + } + else if ( scale->dim < dim ) + error(E_SIZES,"_zv_norm_inf"); + else + for ( i = 0; i < dim; i++ ) + { + s = scale->ve[i]; + tmp = ( s == 0.0 ) ? zabs(x->ve[i]) : zabs(x->ve[i])/fabs(s); + maxval = max(maxval,tmp); + } + + return maxval; +} + +/* zm_norm1 -- compute matrix 1-norm -- unscaled + -- complex version */ +double zm_norm1(A) +ZMAT *A; +{ + int i, j, m, n; + Real maxval, sum; + + if ( A == ZMNULL ) + error(E_NULL,"zm_norm1"); + + m = A->m; n = A->n; + maxval = 0.0; + + for ( j = 0; j < n; j++ ) + { + sum = 0.0; + for ( i = 0; i < m; i ++ ) + sum += zabs(A->me[i][j]); + maxval = max(maxval,sum); + } + + return maxval; +} + +/* zm_norm_inf -- compute matrix infinity-norm -- unscaled + -- complex version */ +double zm_norm_inf(A) +ZMAT *A; +{ + int i, j, m, n; + Real maxval, sum; + + if ( A == ZMNULL ) + error(E_NULL,"zm_norm_inf"); + + m = A->m; n = A->n; + maxval = 0.0; + + for ( i = 0; i < m; i++ ) + { + sum = 0.0; + for ( j = 0; j < n; j ++ ) + sum += zabs(A->me[i][j]); + maxval = max(maxval,sum); + } + + return maxval; +} + +/* zm_norm_frob -- compute matrix frobenius-norm -- unscaled */ +double zm_norm_frob(A) +ZMAT *A; +{ + int i, j, m, n; + Real sum; + + if ( A == ZMNULL ) + error(E_NULL,"zm_norm_frob"); + + m = A->m; n = A->n; + sum = 0.0; + + for ( i = 0; i < m; i++ ) + for ( j = 0; j < n; j ++ ) + sum += square(A->me[i][j].re) + square(A->me[i][j].im); + + return sqrt(sum); +} + diff --git a/meschach/zqrfctr.c b/meschach/zqrfctr.c new file mode 100644 index 0000000..4e0389b --- /dev/null +++ b/meschach/zqrfctr.c @@ -0,0 +1,525 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + +/* + This file contains the routines needed to perform QR factorisation + of matrices, as well as Householder transformations. + The internal "factored form" of a matrix A is not quite standard. + The diagonal of A is replaced by the diagonal of R -- not by the 1st non-zero + entries of the Householder vectors. The 1st non-zero entries are held in + the diag parameter of QRfactor(). The reason for this non-standard + representation is that it enables direct use of the Usolve() function + rather than requiring that a seperate function be written just for this case. + See, e.g., QRsolve() below for more details. + + Complex version + +*/ + +static char rcsid[] = "$Id: zqrfctr.c,v 1.1 2001/03/01 17:19:23 rfranke Exp $"; + +#include +#include +#include "zmatrix.h" +#include "zmatrix2.h" + + +#define is_zero(z) ((z).re == 0.0 && (z).im == 0.0) + + +#define sign(x) ((x) > 0.0 ? 1 : ((x) < 0.0 ? -1 : 0 )) + +/* Note: The usual representation of a Householder transformation is taken + to be: + P = I - beta.u.u* + where beta = 2/(u*.u) and u is called the Householder vector + (u* is the conjugate transposed vector of u +*/ + +/* zQRfactor -- forms the QR factorisation of A + -- factorisation stored in compact form as described above + (not quite standard format) */ +ZMAT *zQRfactor(A,diag) +ZMAT *A; +ZVEC *diag; +{ + u_int k,limit; + Real beta; + static ZVEC *tmp1=ZVNULL; + + if ( ! A || ! diag ) + error(E_NULL,"zQRfactor"); + limit = min(A->m,A->n); + if ( diag->dim < limit ) + error(E_SIZES,"zQRfactor"); + + tmp1 = zv_resize(tmp1,A->m); + MEM_STAT_REG(tmp1,TYPE_ZVEC); + + for ( k=0; kve[k],tmp1,&A->me[k][k]); */ + zhhvec(tmp1,k,&beta,tmp1,&A->me[k][k]); + diag->ve[k] = tmp1->ve[k]; + + /* apply H/holder vector to remaining columns */ + /* hhtrcols(A,k,k+1,tmp1,beta->ve[k]); */ + tracecatch(zhhtrcols(A,k,k+1,tmp1,beta),"zQRfactor"); + } + + return (A); +} + +/* zQRCPfactor -- forms the QR factorisation of A with column pivoting + -- factorisation stored in compact form as described above + ( not quite standard format ) */ +ZMAT *zQRCPfactor(A,diag,px) +ZMAT *A; +ZVEC *diag; +PERM *px; +{ + u_int i, i_max, j, k, limit; + static ZVEC *tmp1=ZVNULL, *tmp2=ZVNULL; + static VEC *gamma=VNULL; + Real beta; + Real maxgamma, sum, tmp; + complex ztmp; + + if ( ! A || ! diag || ! px ) + error(E_NULL,"QRCPfactor"); + limit = min(A->m,A->n); + if ( diag->dim < limit || px->size != A->n ) + error(E_SIZES,"QRCPfactor"); + + tmp1 = zv_resize(tmp1,A->m); + tmp2 = zv_resize(tmp2,A->m); + gamma = v_resize(gamma,A->n); + MEM_STAT_REG(tmp1,TYPE_ZVEC); + MEM_STAT_REG(tmp2,TYPE_ZVEC); + MEM_STAT_REG(gamma,TYPE_VEC); + + /* initialise gamma and px */ + for ( j=0; jn; j++ ) + { + px->pe[j] = j; + sum = 0.0; + for ( i=0; im; i++ ) + sum += square(A->me[i][j].re) + square(A->me[i][j].im); + gamma->ve[j] = sum; + } + + for ( k=0; kve[k]; + for ( i=k+1; in; i++ ) + /* Loop invariant:maxgamma=gamma[i_max] + >=gamma[l];l=k,...,i-1 */ + if ( gamma->ve[i] > maxgamma ) + { maxgamma = gamma->ve[i]; i_max = i; } + + /* swap columns if necessary */ + if ( i_max != k ) + { + /* swap gamma values */ + tmp = gamma->ve[k]; + gamma->ve[k] = gamma->ve[i_max]; + gamma->ve[i_max] = tmp; + + /* update column permutation */ + px_transp(px,k,i_max); + + /* swap columns of A */ + for ( i=0; im; i++ ) + { + ztmp = A->me[i][k]; + A->me[i][k] = A->me[i][i_max]; + A->me[i][i_max] = ztmp; + } + } + + /* get H/holder vector for the k-th column */ + zget_col(A,k,tmp1); + /* hhvec(tmp1,k,&beta->ve[k],tmp1,&A->me[k][k]); */ + zhhvec(tmp1,k,&beta,tmp1,&A->me[k][k]); + diag->ve[k] = tmp1->ve[k]; + + /* apply H/holder vector to remaining columns */ + /* hhtrcols(A,k,k+1,tmp1,beta->ve[k]); */ + zhhtrcols(A,k,k+1,tmp1,beta); + + /* update gamma values */ + for ( j=k+1; jn; j++ ) + gamma->ve[j] -= square(A->me[k][j].re)+square(A->me[k][j].im); + } + + return (A); +} + +/* zQsolve -- solves Qx = b, Q is an orthogonal matrix stored in compact + form a la QRfactor() + -- may be in-situ */ +ZVEC *_zQsolve(QR,diag,b,x,tmp) +ZMAT *QR; +ZVEC *diag, *b, *x, *tmp; +{ + u_int dynamic; + int k, limit; + Real beta, r_ii, tmp_val; + + limit = min(QR->m,QR->n); + dynamic = FALSE; + if ( ! QR || ! diag || ! b ) + error(E_NULL,"_zQsolve"); + if ( diag->dim < limit || b->dim != QR->m ) + error(E_SIZES,"_zQsolve"); + x = zv_resize(x,QR->m); + if ( tmp == ZVNULL ) + dynamic = TRUE; + tmp = zv_resize(tmp,QR->m); + + /* apply H/holder transforms in normal order */ + x = zv_copy(b,x); + for ( k = 0 ; k < limit ; k++ ) + { + zget_col(QR,k,tmp); + r_ii = zabs(tmp->ve[k]); + tmp->ve[k] = diag->ve[k]; + tmp_val = (r_ii*zabs(diag->ve[k])); + beta = ( tmp_val == 0.0 ) ? 0.0 : 1.0/tmp_val; + /* hhtrvec(tmp,beta->ve[k],k,x,x); */ + zhhtrvec(tmp,beta,k,x,x); + } + + if ( dynamic ) + ZV_FREE(tmp); + + return (x); +} + +/* zmakeQ -- constructs orthogonal matrix from Householder vectors stored in + compact QR form */ +ZMAT *zmakeQ(QR,diag,Qout) +ZMAT *QR,*Qout; +ZVEC *diag; +{ + static ZVEC *tmp1=ZVNULL,*tmp2=ZVNULL; + u_int i, limit; + Real beta, r_ii, tmp_val; + int j; + + limit = min(QR->m,QR->n); + if ( ! QR || ! diag ) + error(E_NULL,"zmakeQ"); + if ( diag->dim < limit ) + error(E_SIZES,"zmakeQ"); + Qout = zm_resize(Qout,QR->m,QR->m); + + tmp1 = zv_resize(tmp1,QR->m); /* contains basis vec & columns of Q */ + tmp2 = zv_resize(tmp2,QR->m); /* contains H/holder vectors */ + MEM_STAT_REG(tmp1,TYPE_ZVEC); + MEM_STAT_REG(tmp2,TYPE_ZVEC); + + for ( i=0; im ; i++ ) + { /* get i-th column of Q */ + /* set up tmp1 as i-th basis vector */ + for ( j=0; jm ; j++ ) + tmp1->ve[j].re = tmp1->ve[j].im = 0.0; + tmp1->ve[i].re = 1.0; + + /* apply H/h transforms in reverse order */ + for ( j=limit-1; j>=0; j-- ) + { + zget_col(QR,j,tmp2); + r_ii = zabs(tmp2->ve[j]); + tmp2->ve[j] = diag->ve[j]; + tmp_val = (r_ii*zabs(diag->ve[j])); + beta = ( tmp_val == 0.0 ) ? 0.0 : 1.0/tmp_val; + /* hhtrvec(tmp2,beta->ve[j],j,tmp1,tmp1); */ + zhhtrvec(tmp2,beta,j,tmp1,tmp1); + } + + /* insert into Q */ + zset_col(Qout,i,tmp1); + } + + return (Qout); +} + +/* zmakeR -- constructs upper triangular matrix from QR (compact form) + -- may be in-situ (all it does is zero the lower 1/2) */ +ZMAT *zmakeR(QR,Rout) +ZMAT *QR,*Rout; +{ + u_int i,j; + + if ( QR==ZMNULL ) + error(E_NULL,"zmakeR"); + Rout = zm_copy(QR,Rout); + + for ( i=1; im; i++ ) + for ( j=0; jn && jme[i][j].re = Rout->me[i][j].im = 0.0; + + return (Rout); +} + +/* zQRsolve -- solves the system Q.R.x=b where Q & R are stored in compact form + -- returns x, which is created if necessary */ +ZVEC *zQRsolve(QR,diag,b,x) +ZMAT *QR; +ZVEC *diag, *b, *x; +{ + int limit; + static ZVEC *tmp = ZVNULL; + + if ( ! QR || ! diag || ! b ) + error(E_NULL,"zQRsolve"); + limit = min(QR->m,QR->n); + if ( diag->dim < limit || b->dim != QR->m ) + error(E_SIZES,"zQRsolve"); + tmp = zv_resize(tmp,limit); + MEM_STAT_REG(tmp,TYPE_ZVEC); + + x = zv_resize(x,QR->n); + _zQsolve(QR,diag,b,x,tmp); + x = zUsolve(QR,x,x,0.0); + x = zv_resize(x,QR->n); + + return x; +} + +/* zQRAsolve -- solves the system (Q.R)*.x = b + -- Q & R are stored in compact form + -- returns x, which is created if necessary */ +ZVEC *zQRAsolve(QR,diag,b,x) +ZMAT *QR; +ZVEC *diag, *b, *x; +{ + int j, limit; + Real beta, r_ii, tmp_val; + static ZVEC *tmp = ZVNULL; + + if ( ! QR || ! diag || ! b ) + error(E_NULL,"zQRAsolve"); + limit = min(QR->m,QR->n); + if ( diag->dim < limit || b->dim != QR->n ) + error(E_SIZES,"zQRAsolve"); + + x = zv_resize(x,QR->m); + x = zUAsolve(QR,b,x,0.0); + x = zv_resize(x,QR->m); + + tmp = zv_resize(tmp,x->dim); + MEM_STAT_REG(tmp,TYPE_ZVEC); + printf("zQRAsolve: tmp->dim = %d, x->dim = %d\n", tmp->dim, x->dim); + + /* apply H/h transforms in reverse order */ + for ( j=limit-1; j>=0; j-- ) + { + zget_col(QR,j,tmp); + tmp = zv_resize(tmp,QR->m); + r_ii = zabs(tmp->ve[j]); + tmp->ve[j] = diag->ve[j]; + tmp_val = (r_ii*zabs(diag->ve[j])); + beta = ( tmp_val == 0.0 ) ? 0.0 : 1.0/tmp_val; + zhhtrvec(tmp,beta,j,x,x); + } + + + return x; +} + +/* zQRCPsolve -- solves A.x = b where A is factored by QRCPfactor() + -- assumes that A is in the compact factored form */ +ZVEC *zQRCPsolve(QR,diag,pivot,b,x) +ZMAT *QR; +ZVEC *diag; +PERM *pivot; +ZVEC *b, *x; +{ + if ( ! QR || ! diag || ! pivot || ! b ) + error(E_NULL,"zQRCPsolve"); + if ( (QR->m > diag->dim && QR->n > diag->dim) || QR->n != pivot->size ) + error(E_SIZES,"zQRCPsolve"); + + x = zQRsolve(QR,diag,b,x); + x = pxinv_zvec(pivot,x,x); + + return x; +} + +/* zUmlt -- compute out = upper_triang(U).x + -- may be in situ */ +ZVEC *zUmlt(U,x,out) +ZMAT *U; +ZVEC *x, *out; +{ + int i, limit; + + if ( U == ZMNULL || x == ZVNULL ) + error(E_NULL,"zUmlt"); + limit = min(U->m,U->n); + if ( limit != x->dim ) + error(E_SIZES,"zUmlt"); + if ( out == ZVNULL || out->dim < limit ) + out = zv_resize(out,limit); + + for ( i = 0; i < limit; i++ ) + out->ve[i] = __zip__(&(x->ve[i]),&(U->me[i][i]),limit - i,Z_NOCONJ); + return out; +} + +/* zUAmlt -- returns out = upper_triang(U)^T.x */ +ZVEC *zUAmlt(U,x,out) +ZMAT *U; +ZVEC *x, *out; +{ + /* complex sum; */ + complex tmp; + int i, limit; + + if ( U == ZMNULL || x == ZVNULL ) + error(E_NULL,"zUAmlt"); + limit = min(U->m,U->n); + if ( out == ZVNULL || out->dim < limit ) + out = zv_resize(out,limit); + + for ( i = limit-1; i >= 0; i-- ) + { + tmp = x->ve[i]; + out->ve[i].re = out->ve[i].im = 0.0; + __zmltadd__(&(out->ve[i]),&(U->me[i][i]),tmp,limit-i-1,Z_CONJ); + } + + return out; +} + + +/* zQRcondest -- returns an estimate of the 2-norm condition number of the + matrix factorised by QRfactor() or QRCPfactor() + -- note that as Q does not affect the 2-norm condition number, + it is not necessary to pass the diag, beta (or pivot) vectors + -- generates a lower bound on the true condition number + -- if the matrix is exactly singular, HUGE is returned + -- note that QRcondest() is likely to be more reliable for + matrices factored using QRCPfactor() */ +double zQRcondest(QR) +ZMAT *QR; +{ + static ZVEC *y=ZVNULL; + Real norm, norm1, norm2, tmp1, tmp2; + complex sum, tmp; + int i, j, limit; + + if ( QR == ZMNULL ) + error(E_NULL,"zQRcondest"); + + limit = min(QR->m,QR->n); + for ( i = 0; i < limit; i++ ) + /* if ( QR->me[i][i] == 0.0 ) */ + if ( is_zero(QR->me[i][i]) ) + return HUGE; + + y = zv_resize(y,limit); + MEM_STAT_REG(y,TYPE_ZVEC); + /* use the trick for getting a unit vector y with ||R.y||_inf small + from the LU condition estimator */ + for ( i = 0; i < limit; i++ ) + { + sum.re = sum.im = 0.0; + for ( j = 0; j < i; j++ ) + /* sum -= QR->me[j][i]*y->ve[j]; */ + sum = zsub(sum,zmlt(QR->me[j][i],y->ve[j])); + /* sum -= (sum < 0.0) ? 1.0 : -1.0; */ + norm1 = zabs(sum); + if ( norm1 == 0.0 ) + sum.re = 1.0; + else + { + sum.re += sum.re / norm1; + sum.im += sum.im / norm1; + } + /* y->ve[i] = sum / QR->me[i][i]; */ + y->ve[i] = zdiv(sum,QR->me[i][i]); + } + zUAmlt(QR,y,y); + + /* now apply inverse power method to R*.R */ + for ( i = 0; i < 3; i++ ) + { + tmp1 = zv_norm2(y); + zv_mlt(zmake(1.0/tmp1,0.0),y,y); + zUAsolve(QR,y,y,0.0); + tmp2 = zv_norm2(y); + zv_mlt(zmake(1.0/tmp2,0.0),y,y); + zUsolve(QR,y,y,0.0); + } + /* now compute approximation for ||R^{-1}||_2 */ + norm1 = sqrt(tmp1)*sqrt(tmp2); + + /* now use complementary approach to compute approximation to ||R||_2 */ + for ( i = limit-1; i >= 0; i-- ) + { + sum.re = sum.im = 0.0; + for ( j = i+1; j < limit; j++ ) + sum = zadd(sum,zmlt(QR->me[i][j],y->ve[j])); + if ( is_zero(QR->me[i][i]) ) + return HUGE; + tmp = zdiv(sum,QR->me[i][i]); + if ( is_zero(tmp) ) + { + y->ve[i].re = 1.0; + y->ve[i].im = 0.0; + } + else + { + norm = zabs(tmp); + y->ve[i].re = sum.re / norm; + y->ve[i].im = sum.im / norm; + } + /* y->ve[i] = (sum >= 0.0) ? 1.0 : -1.0; */ + /* y->ve[i] = (QR->me[i][i] >= 0.0) ? y->ve[i] : - y->ve[i]; */ + } + + /* now apply power method to R*.R */ + for ( i = 0; i < 3; i++ ) + { + tmp1 = zv_norm2(y); + zv_mlt(zmake(1.0/tmp1,0.0),y,y); + zUmlt(QR,y,y); + tmp2 = zv_norm2(y); + zv_mlt(zmake(1.0/tmp2,0.0),y,y); + zUAmlt(QR,y,y); + } + norm2 = sqrt(tmp1)*sqrt(tmp2); + + /* printf("QRcondest: norm1 = %g, norm2 = %g\n",norm1,norm2); */ + + return norm1*norm2; +} + diff --git a/meschach/zschur.c b/meschach/zschur.c new file mode 100644 index 0000000..2c79d41 --- /dev/null +++ b/meschach/zschur.c @@ -0,0 +1,375 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + +/* + File containing routines for computing the Schur decomposition + of a complex non-symmetric matrix + See also: hessen.c + Complex version +*/ + + +#include +#include +#include "zmatrix.h" +#include "zmatrix2.h" + + +#define is_zero(z) ((z).re == 0.0 && (z).im == 0.0) +#define b2s(t_or_f) ((t_or_f) ? "TRUE" : "FALSE") + + +/* zschur -- computes the Schur decomposition of the matrix A in situ + -- optionally, gives Q matrix such that Q^T.A.Q is upper triangular + -- returns upper triangular Schur matrix */ +ZMAT *zschur(A,Q) +ZMAT *A, *Q; +{ + int i, j, iter, k, k_min, k_max, k_tmp, n, split; + Real c; + complex det, discrim, lambda, lambda0, lambda1, s, sum, ztmp; + complex x, y; /* for chasing algorithm */ + complex **A_me; + static ZVEC *diag=ZVNULL; + + if ( ! A ) + error(E_NULL,"zschur"); + if ( A->m != A->n || ( Q && Q->m != Q->n ) ) + error(E_SQUARE,"zschur"); + if ( Q != ZMNULL && Q->m != A->m ) + error(E_SIZES,"zschur"); + n = A->n; + diag = zv_resize(diag,A->n); + MEM_STAT_REG(diag,TYPE_ZVEC); + /* compute Hessenberg form */ + zHfactor(A,diag); + + /* save Q if necessary, and make A explicitly Hessenberg */ + zHQunpack(A,diag,Q,A); + + k_min = 0; A_me = A->me; + + while ( k_min < n ) + { + /* find k_max to suit: + submatrix k_min..k_max should be irreducible */ + k_max = n-1; + for ( k = k_min; k < k_max; k++ ) + if ( is_zero(A_me[k+1][k]) ) + { k_max = k; break; } + + if ( k_max <= k_min ) + { + k_min = k_max + 1; + continue; /* outer loop */ + } + + /* now have r x r block with r >= 2: + apply Francis QR step until block splits */ + split = FALSE; iter = 0; + while ( ! split ) + { + complex a00, a01, a10, a11; + iter++; + + /* set up Wilkinson/Francis complex shift */ + /* use the smallest eigenvalue of the bottom 2 x 2 submatrix */ + k_tmp = k_max - 1; + + a00 = A_me[k_tmp][k_tmp]; + a01 = A_me[k_tmp][k_max]; + a10 = A_me[k_max][k_tmp]; + a11 = A_me[k_max][k_max]; + ztmp.re = 0.5*(a00.re - a11.re); + ztmp.im = 0.5*(a00.im - a11.im); + discrim = zsqrt(zadd(zmlt(ztmp,ztmp),zmlt(a01,a10))); + sum.re = 0.5*(a00.re + a11.re); + sum.im = 0.5*(a00.im + a11.im); + lambda0 = zadd(sum,discrim); + lambda1 = zsub(sum,discrim); + det = zsub(zmlt(a00,a11),zmlt(a01,a10)); + if ( zabs(lambda0) > zabs(lambda1) ) + lambda = zdiv(det,lambda0); + else + lambda = zdiv(det,lambda1); + + /* perturb shift if convergence is slow */ + if ( (iter % 10) == 0 ) + { + lambda.re += iter*0.02; + lambda.im += iter*0.02; + } + + /* set up Householder transformations */ + k_tmp = k_min + 1; + + x = zsub(A->me[k_min][k_min],lambda); + y = A->me[k_min+1][k_min]; + + /* use Givens' rotations to "chase" off-Hessenberg entry */ + for ( k = k_min; k <= k_max-1; k++ ) + { + zgivens(x,y,&c,&s); + zrot_cols(A,k,k+1,c,s,A); + zrot_rows(A,k,k+1,c,s,A); + if ( Q != ZMNULL ) + zrot_cols(Q,k,k+1,c,s,Q); + + /* zero things that should be zero */ + if ( k > k_min ) + A->me[k+1][k-1].re = A->me[k+1][k-1].im = 0.0; + + /* get next entry to chase along sub-diagonal */ + x = A->me[k+1][k]; + if ( k <= k_max - 2 ) + y = A->me[k+2][k]; + else + y.re = y.im = 0.0; + } + + for ( k = k_min; k <= k_max-2; k++ ) + { + /* zero appropriate sub-diagonals */ + A->me[k+2][k].re = A->me[k+2][k].im = 0.0; + } + + /* test to see if matrix should split */ + for ( k = k_min; k < k_max; k++ ) + if ( zabs(A_me[k+1][k]) < MACHEPS* + (zabs(A_me[k][k])+zabs(A_me[k+1][k+1])) ) + { + A_me[k+1][k].re = A_me[k+1][k].im = 0.0; + split = TRUE; + } + + } + } + + /* polish up A by zeroing strictly lower triangular elements + and small sub-diagonal elements */ + for ( i = 0; i < A->m; i++ ) + for ( j = 0; j < i-1; j++ ) + A_me[i][j].re = A_me[i][j].im = 0.0; + for ( i = 0; i < A->m - 1; i++ ) + if ( zabs(A_me[i+1][i]) < MACHEPS* + (zabs(A_me[i][i])+zabs(A_me[i+1][i+1])) ) + A_me[i+1][i].re = A_me[i+1][i].im = 0.0; + + return A; +} + + +#if 0 +/* schur_vecs -- returns eigenvectors computed from the real Schur + decomposition of a matrix + -- T is the block upper triangular Schur matrix + -- Q is the orthognal matrix where A = Q.T.Q^T + -- if Q is null, the eigenvectors of T are returned + -- X_re is the real part of the matrix of eigenvectors, + and X_im is the imaginary part of the matrix. + -- X_re is returned */ +MAT *schur_vecs(T,Q,X_re,X_im) +MAT *T, *Q, *X_re, *X_im; +{ + int i, j, limit; + Real t11_re, t11_im, t12, t21, t22_re, t22_im; + Real l_re, l_im, det_re, det_im, invdet_re, invdet_im, + val1_re, val1_im, val2_re, val2_im, + tmp_val1_re, tmp_val1_im, tmp_val2_re, tmp_val2_im, **T_me; + Real sum, diff, discrim, magdet, norm, scale; + static VEC *tmp1_re=VNULL, *tmp1_im=VNULL, + *tmp2_re=VNULL, *tmp2_im=VNULL; + + if ( ! T || ! X_re ) + error(E_NULL,"schur_vecs"); + if ( T->m != T->n || X_re->m != X_re->n || + ( Q != MNULL && Q->m != Q->n ) || + ( X_im != MNULL && X_im->m != X_im->n ) ) + error(E_SQUARE,"schur_vecs"); + if ( T->m != X_re->m || + ( Q != MNULL && T->m != Q->m ) || + ( X_im != MNULL && T->m != X_im->m ) ) + error(E_SIZES,"schur_vecs"); + + tmp1_re = v_resize(tmp1_re,T->m); + tmp1_im = v_resize(tmp1_im,T->m); + tmp2_re = v_resize(tmp2_re,T->m); + tmp2_im = v_resize(tmp2_im,T->m); + MEM_STAT_REG(tmp1_re,TYPE_VEC); + MEM_STAT_REG(tmp1_im,TYPE_VEC); + MEM_STAT_REG(tmp2_re,TYPE_VEC); + MEM_STAT_REG(tmp2_im,TYPE_VEC); + + T_me = T->me; + i = 0; + while ( i < T->m ) + { + if ( i+1 < T->m && T->me[i+1][i] != 0.0 ) + { /* complex eigenvalue */ + sum = 0.5*(T_me[i][i]+T_me[i+1][i+1]); + diff = 0.5*(T_me[i][i]-T_me[i+1][i+1]); + discrim = diff*diff + T_me[i][i+1]*T_me[i+1][i]; + l_re = l_im = 0.0; + if ( discrim < 0.0 ) + { /* yes -- complex e-vals */ + l_re = sum; + l_im = sqrt(-discrim); + } + else /* not correct Real Schur form */ + error(E_RANGE,"schur_vecs"); + } + else + { + l_re = T_me[i][i]; + l_im = 0.0; + } + + v_zero(tmp1_im); + v_rand(tmp1_re); + sv_mlt(MACHEPS,tmp1_re,tmp1_re); + + /* solve (T-l.I)x = tmp1 */ + limit = ( l_im != 0.0 ) ? i+1 : i; + /* printf("limit = %d\n",limit); */ + for ( j = limit+1; j < T->m; j++ ) + tmp1_re->ve[j] = 0.0; + j = limit; + while ( j >= 0 ) + { + if ( j > 0 && T->me[j][j-1] != 0.0 ) + { /* 2 x 2 diagonal block */ + /* printf("checkpoint A\n"); */ + val1_re = tmp1_re->ve[j-1] - + __ip__(&(tmp1_re->ve[j+1]),&(T->me[j-1][j+1]),limit-j); + /* printf("checkpoint B\n"); */ + val1_im = tmp1_im->ve[j-1] - + __ip__(&(tmp1_im->ve[j+1]),&(T->me[j-1][j+1]),limit-j); + /* printf("checkpoint C\n"); */ + val2_re = tmp1_re->ve[j] - + __ip__(&(tmp1_re->ve[j+1]),&(T->me[j][j+1]),limit-j); + /* printf("checkpoint D\n"); */ + val2_im = tmp1_im->ve[j] - + __ip__(&(tmp1_im->ve[j+1]),&(T->me[j][j+1]),limit-j); + /* printf("checkpoint E\n"); */ + + t11_re = T_me[j-1][j-1] - l_re; + t11_im = - l_im; + t22_re = T_me[j][j] - l_re; + t22_im = - l_im; + t12 = T_me[j-1][j]; + t21 = T_me[j][j-1]; + + scale = fabs(T_me[j-1][j-1]) + fabs(T_me[j][j]) + + fabs(t12) + fabs(t21) + fabs(l_re) + fabs(l_im); + + det_re = t11_re*t22_re - t11_im*t22_im - t12*t21; + det_im = t11_re*t22_im + t11_im*t22_re; + magdet = det_re*det_re+det_im*det_im; + if ( sqrt(magdet) < MACHEPS*scale ) + { + det_re = MACHEPS*scale; + magdet = det_re*det_re+det_im*det_im; + } + invdet_re = det_re/magdet; + invdet_im = - det_im/magdet; + tmp_val1_re = t22_re*val1_re-t22_im*val1_im-t12*val2_re; + tmp_val1_im = t22_im*val1_re+t22_re*val1_im-t12*val2_im; + tmp_val2_re = t11_re*val2_re-t11_im*val2_im-t21*val1_re; + tmp_val2_im = t11_im*val2_re+t11_re*val2_im-t21*val1_im; + tmp1_re->ve[j-1] = invdet_re*tmp_val1_re - + invdet_im*tmp_val1_im; + tmp1_im->ve[j-1] = invdet_im*tmp_val1_re + + invdet_re*tmp_val1_im; + tmp1_re->ve[j] = invdet_re*tmp_val2_re - + invdet_im*tmp_val2_im; + tmp1_im->ve[j] = invdet_im*tmp_val2_re + + invdet_re*tmp_val2_im; + j -= 2; + } + else + { + t11_re = T_me[j][j] - l_re; + t11_im = - l_im; + magdet = t11_re*t11_re + t11_im*t11_im; + scale = fabs(T_me[j][j]) + fabs(l_re); + if ( sqrt(magdet) < MACHEPS*scale ) + { + t11_re = MACHEPS*scale; + magdet = t11_re*t11_re + t11_im*t11_im; + } + invdet_re = t11_re/magdet; + invdet_im = - t11_im/magdet; + /* printf("checkpoint F\n"); */ + val1_re = tmp1_re->ve[j] - + __ip__(&(tmp1_re->ve[j+1]),&(T->me[j][j+1]),limit-j); + /* printf("checkpoint G\n"); */ + val1_im = tmp1_im->ve[j] - + __ip__(&(tmp1_im->ve[j+1]),&(T->me[j][j+1]),limit-j); + /* printf("checkpoint H\n"); */ + tmp1_re->ve[j] = invdet_re*val1_re - invdet_im*val1_im; + tmp1_im->ve[j] = invdet_im*val1_re + invdet_re*val1_im; + j -= 1; + } + } + + norm = v_norm_inf(tmp1_re) + v_norm_inf(tmp1_im); + sv_mlt(1/norm,tmp1_re,tmp1_re); + if ( l_im != 0.0 ) + sv_mlt(1/norm,tmp1_im,tmp1_im); + mv_mlt(Q,tmp1_re,tmp2_re); + if ( l_im != 0.0 ) + mv_mlt(Q,tmp1_im,tmp2_im); + if ( l_im != 0.0 ) + norm = sqrt(in_prod(tmp2_re,tmp2_re)+in_prod(tmp2_im,tmp2_im)); + else + norm = v_norm2(tmp2_re); + sv_mlt(1/norm,tmp2_re,tmp2_re); + if ( l_im != 0.0 ) + sv_mlt(1/norm,tmp2_im,tmp2_im); + + if ( l_im != 0.0 ) + { + if ( ! X_im ) + error(E_NULL,"schur_vecs"); + set_col(X_re,i,tmp2_re); + set_col(X_im,i,tmp2_im); + sv_mlt(-1.0,tmp2_im,tmp2_im); + set_col(X_re,i+1,tmp2_re); + set_col(X_im,i+1,tmp2_im); + i += 2; + } + else + { + set_col(X_re,i,tmp2_re); + if ( X_im != MNULL ) + set_col(X_im,i,tmp1_im); /* zero vector */ + i += 1; + } + } + + return X_re; +} + +#endif diff --git a/meschach/zsolve.c b/meschach/zsolve.c new file mode 100644 index 0000000..82a507f --- /dev/null +++ b/meschach/zsolve.c @@ -0,0 +1,300 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + Matrix factorisation routines to work with the other matrix files. + Complex case +*/ + +static char rcsid[] = "$Id: zsolve.c,v 1.1 2001/03/01 17:19:24 rfranke Exp $"; + +#include +#include +#include "zmatrix2.h" + + +#define is_zero(z) ((z).re == 0.0 && (z).im == 0.0 ) + +/* Most matrix factorisation routines are in-situ unless otherwise specified */ + +/* zUsolve -- back substitution with optional over-riding diagonal + -- can be in-situ but doesn't need to be */ +ZVEC *zUsolve(matrix,b,out,diag) +ZMAT *matrix; +ZVEC *b, *out; +double diag; +{ + u_int dim /* , j */; + int i, i_lim; + complex **mat_ent, *mat_row, *b_ent, *out_ent, *out_col, sum; + + if ( matrix==ZMNULL || b==ZVNULL ) + error(E_NULL,"zUsolve"); + dim = min(matrix->m,matrix->n); + if ( b->dim < dim ) + error(E_SIZES,"zUsolve"); + if ( out==ZVNULL || out->dim < dim ) + out = zv_resize(out,matrix->n); + mat_ent = matrix->me; b_ent = b->ve; out_ent = out->ve; + + for ( i=dim-1; i>=0; i-- ) + if ( ! is_zero(b_ent[i]) ) + break; + else + out_ent[i].re = out_ent[i].im = 0.0; + i_lim = i; + + for ( i = i_lim; i>=0; i-- ) + { + sum = b_ent[i]; + mat_row = &(mat_ent[i][i+1]); + out_col = &(out_ent[i+1]); + sum = zsub(sum,__zip__(mat_row,out_col,i_lim-i,Z_NOCONJ)); + /****************************************************** + for ( j=i+1; j<=i_lim; j++ ) + sum -= mat_ent[i][j]*out_ent[j]; + sum -= (*mat_row++)*(*out_col++); + ******************************************************/ + if ( diag == 0.0 ) + { + if ( is_zero(mat_ent[i][i]) ) + error(E_SING,"zUsolve"); + else + /* out_ent[i] = sum/mat_ent[i][i]; */ + out_ent[i] = zdiv(sum,mat_ent[i][i]); + } + else + { + /* out_ent[i] = sum/diag; */ + out_ent[i].re = sum.re / diag; + out_ent[i].im = sum.im / diag; + } + } + + return (out); +} + +/* zLsolve -- forward elimination with (optional) default diagonal value */ +ZVEC *zLsolve(matrix,b,out,diag) +ZMAT *matrix; +ZVEC *b,*out; +double diag; +{ + u_int dim, i, i_lim /* , j */; + complex **mat_ent, *mat_row, *b_ent, *out_ent, *out_col, sum; + + if ( matrix==ZMNULL || b==ZVNULL ) + error(E_NULL,"zLsolve"); + dim = min(matrix->m,matrix->n); + if ( b->dim < dim ) + error(E_SIZES,"zLsolve"); + if ( out==ZVNULL || out->dim < dim ) + out = zv_resize(out,matrix->n); + mat_ent = matrix->me; b_ent = b->ve; out_ent = out->ve; + + for ( i=0; im,U->n); + if ( b->dim < dim ) + error(E_SIZES,"zUAsolve"); + out = zv_resize(out,U->n); + U_me = U->me; b_ve = b->ve; out_ve = out->ve; + + for ( i=0; idim); + /* MEM_COPY(&(b_ve[i_lim]),&(out_ve[i_lim]), + (dim-i_lim)*sizeof(complex)); */ + MEMCOPY(&(b_ve[i_lim]),&(out_ve[i_lim]),dim-i_lim,complex); + } + + if ( diag == 0.0 ) + { + for ( ; im,A->n); + if ( b->dim < dim ) + error(E_SIZES,"zDsolve"); + x = zv_resize(x,A->n); + + dim = b->dim; + for ( i=0; ime[i][i]) ) + error(E_SING,"zDsolve"); + else + x->ve[i] = zdiv(b->ve[i],A->me[i][i]); + + return (x); +} + +/* zLAsolve -- back substitution with optional over-riding diagonal + using the LOWER triangular part of matrix + -- can be in-situ but doesn't need to be */ +ZVEC *zLAsolve(L,b,out,diag) +ZMAT *L; +ZVEC *b, *out; +double diag; +{ + u_int dim; + int i, i_lim; + complex **L_me, *b_ve, *out_ve, tmp; + Real invdiag; + + if ( ! L || ! b ) + error(E_NULL,"zLAsolve"); + dim = min(L->m,L->n); + if ( b->dim < dim ) + error(E_SIZES,"zLAsolve"); + out = zv_resize(out,L->n); + L_me = L->me; b_ve = b->ve; out_ve = out->ve; + + for ( i=dim-1; i>=0; i-- ) + if ( ! is_zero(b_ve[i]) ) + break; + i_lim = i; + + if ( b != out ) + { + __zzero__(out_ve,out->dim); + /* MEM_COPY(b_ve,out_ve,(i_lim+1)*sizeof(complex)); */ + MEMCOPY(b_ve,out_ve,i_lim+1,complex); + } + + if ( diag == 0.0 ) + { + for ( ; i>=0; i-- ) + { + tmp = zconj(L_me[i][i]); + if ( is_zero(tmp) ) + error(E_SING,"zLAsolve"); + out_ve[i] = zdiv(out_ve[i],tmp); + tmp.re = - out_ve[i].re; + tmp.im = - out_ve[i].im; + __zmltadd__(out_ve,L_me[i],tmp,i,Z_CONJ); + } + } + else + { + invdiag = 1.0/diag; + for ( ; i>=0; i-- ) + { + out_ve[i].re *= invdiag; + out_ve[i].im *= invdiag; + tmp.re = - out_ve[i].re; + tmp.im = - out_ve[i].im; + __zmltadd__(out_ve,L_me[i],tmp,i,Z_CONJ); + } + } + + return (out); +} diff --git a/meschach/ztorture.c b/meschach/ztorture.c new file mode 100644 index 0000000..425b381 --- /dev/null +++ b/meschach/ztorture.c @@ -0,0 +1,715 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +/* + This file contains a series of tests for the Meschach matrix + library, complex routines +*/ + +static char rcsid[] = "$Id: ztorture.c,v 1.1 2001/03/01 17:19:25 rfranke Exp $"; + +#include +#include +#include "zmatrix2.h" +#include "matlab.h" + + +#define errmesg(mesg) printf("Error: %s error: line %d\n",mesg,__LINE__) +#define notice(mesg) printf("# Testing %s...\n",mesg); + +/* extern int malloc_chain_check(); */ +/* #define MEMCHK() if ( malloc_chain_check(0) ) \ +{ printf("Error in malloc chain: \"%s\", line %d\n", \ + __FILE__, __LINE__); exit(0); } */ +#define MEMCHK() + +/* cmp_perm -- returns 1 if pi1 == pi2, 0 otherwise */ +int cmp_perm(pi1, pi2) +PERM *pi1, *pi2; +{ + int i; + + if ( ! pi1 || ! pi2 ) + error(E_NULL,"cmp_perm"); + if ( pi1->size != pi2->size ) + return 0; + for ( i = 0; i < pi1->size; i++ ) + if ( pi1->pe[i] != pi2->pe[i] ) + return 0; + return 1; +} + +/* px_rand -- generates sort-of random permutation */ +PERM *px_rand(pi) +PERM *pi; +{ + int i, j, k; + + if ( ! pi ) + error(E_NULL,"px_rand"); + + for ( i = 0; i < 3*pi->size; i++ ) + { + j = (rand() >> 8) % pi->size; + k = (rand() >> 8) % pi->size; + px_transp(pi,j,k); + } + + return pi; +} + +#define SAVE_FILE "asx5213a.mat" +#define MATLAB_NAME "alpha" +char name[81] = MATLAB_NAME; + +void main(argc, argv) +int argc; +char *argv[]; +{ + ZVEC *x = ZVNULL, *y = ZVNULL, *z = ZVNULL, *u = ZVNULL; + ZVEC *diag = ZVNULL; + PERM *pi1 = PNULL, *pi2 = PNULL, *pivot = PNULL; + ZMAT *A = ZMNULL, *B = ZMNULL, *C = ZMNULL, *D = ZMNULL, + *Q = ZMNULL; + complex ONE; + complex z1, z2, z3; + Real cond_est, s1, s2, s3; + int i, seed; + FILE *fp; + char *cp; + + + mem_info_on(TRUE); + + setbuf(stdout,(char *)NULL); + + seed = 1111; + if ( argc > 2 ) + { + printf("usage: %s [seed]\n",argv[0]); + exit(0); + } + else if ( argc == 2 ) + sscanf(argv[1], "%d", &seed); + + /* set seed for rand() */ + smrand(seed); + + /* print out version information */ + m_version(); + + printf("# Meschach Complex numbers & vectors torture test\n\n"); + printf("# grep \"^Error\" the output for a listing of errors\n"); + printf("# Don't panic if you see \"Error\" appearing; \n"); + printf("# Also check the reported size of error\n"); + printf("# This program uses randomly generated problems and therefore\n"); + printf("# may occasionally produce ill-conditioned problems\n"); + printf("# Therefore check the size of the error compared with MACHEPS\n"); + printf("# If the error is within 1000*MACHEPS then don't worry\n"); + printf("# If you get an error of size 0.1 or larger there is \n"); + printf("# probably a bug in the code or the compilation procedure\n\n"); + printf("# seed = %d\n",seed); + + printf("\n"); + + mem_stat_mark(1); + + notice("complex arithmetic & special functions"); + + ONE = zmake(1.0,0.0); + printf("# ONE = "); z_output(ONE); + z1.re = mrand(); z1.im = mrand(); + z2.re = mrand(); z2.im = mrand(); + z3 = zadd(z1,z2); + if ( fabs(z1.re+z2.re-z3.re) + fabs(z1.im+z2.im-z3.im) > 10*MACHEPS ) + errmesg("zadd"); + z3 = zsub(z1,z2); + if ( fabs(z1.re-z2.re-z3.re) + fabs(z1.im-z2.im-z3.im) > 10*MACHEPS ) + errmesg("zadd"); + z3 = zmlt(z1,z2); + if ( fabs(z1.re*z2.re - z1.im*z2.im - z3.re) + + fabs(z1.im*z2.re + z1.re*z2.im - z3.im) > 10*MACHEPS ) + errmesg("zmlt"); + s1 = zabs(z1); + if ( fabs(s1*s1 - (z1.re*z1.re+z1.im*z1.im)) > 10*MACHEPS ) + errmesg("zabs"); + if ( zabs(zsub(z1,zmlt(z2,zdiv(z1,z2)))) > 10*MACHEPS || + zabs(zsub(ONE,zdiv(z1,zmlt(z2,zdiv(z1,z2))))) > 10*MACHEPS ) + errmesg("zdiv"); + + z3 = zsqrt(z1); + if ( zabs(zsub(z1,zmlt(z3,z3))) > 10*MACHEPS ) + errmesg("zsqrt"); + if ( zabs(zsub(z1,zlog(zexp(z1)))) > 10*MACHEPS ) + errmesg("zexp/zlog"); + + + printf("# Check: MACHEPS = %g\n",MACHEPS); + /* allocate, initialise, copy and resize operations */ + /* ZVEC */ + notice("vector initialise, copy & resize"); + x = zv_get(12); + y = zv_get(15); + z = zv_get(12); + zv_rand(x); + zv_rand(y); + z = zv_copy(x,z); + if ( zv_norm2(zv_sub(x,z,z)) >= MACHEPS ) + errmesg("ZVEC copy"); + zv_copy(x,y); + x = zv_resize(x,10); + y = zv_resize(y,10); + if ( zv_norm2(zv_sub(x,y,z)) >= MACHEPS ) + errmesg("ZVEC copy/resize"); + x = zv_resize(x,15); + y = zv_resize(y,15); + if ( zv_norm2(zv_sub(x,y,z)) >= MACHEPS ) + errmesg("VZEC resize"); + + /* ZMAT */ + notice("matrix initialise, copy & resize"); + A = zm_get(8,5); + B = zm_get(3,9); + C = zm_get(8,5); + zm_rand(A); + zm_rand(B); + C = zm_copy(A,C); + if ( zm_norm_inf(zm_sub(A,C,C)) >= MACHEPS ) + errmesg("ZMAT copy"); + zm_copy(A,B); + A = zm_resize(A,3,5); + B = zm_resize(B,3,5); + if ( zm_norm_inf(zm_sub(A,B,C)) >= MACHEPS ) + errmesg("ZMAT copy/resize"); + A = zm_resize(A,10,10); + B = zm_resize(B,10,10); + if ( zm_norm_inf(zm_sub(A,B,C)) >= MACHEPS ) + errmesg("ZMAT resize"); + + MEMCHK(); + + /* PERM */ + notice("permutation initialise, inverting & permuting vectors"); + pi1 = px_get(15); + pi2 = px_get(12); + px_rand(pi1); + zv_rand(x); + px_zvec(pi1,x,z); + y = zv_resize(y,x->dim); + pxinv_zvec(pi1,z,y); + if ( zv_norm2(zv_sub(x,y,z)) >= MACHEPS ) + errmesg("PERMute vector"); + + /* testing m_catch() etc */ + notice("error handling routines"); + m_catch(E_NULL, + catchall(zv_add(ZVNULL,ZVNULL,ZVNULL); + errmesg("tracecatch() failure"), + printf("# tracecatch() caught error\n"); + error(E_NULL,"main")); + errmesg("m_catch() failure"), + printf("# m_catch() caught E_NULL error\n")); + + /* testing inner products and v_mltadd() etc */ + notice("inner products and linear combinations"); + u = zv_get(x->dim); + zv_rand(u); + zv_rand(x); + zv_resize(y,x->dim); + zv_rand(y); + zv_mltadd(y,x,zneg(zdiv(zin_prod(x,y),zin_prod(x,x))),z); + if ( zabs(zin_prod(x,z)) >= MACHEPS*x->dim ) + errmesg("zv_mltadd()/zin_prod()"); + + z1 = zneg(zdiv(zin_prod(x,y),zmake(zv_norm2(x)*zv_norm2(x),0.0))); + zv_mlt(z1,x,u); + zv_add(y,u,u); + if ( zv_norm2(zv_sub(u,z,u)) >= MACHEPS*x->dim ) + { + errmesg("zv_mlt()/zv_norm2()"); + printf("# error norm = %g\n", zv_norm2(u)); + } + +#ifdef ANSI_C + zv_linlist(u,x,z1,y,ONE,VNULL); + if ( zv_norm2(zv_sub(u,z,u)) >= MACHEPS*x->dim ) + errmesg("zv_linlist()"); +#endif +#ifdef VARARGS + zv_linlist(u,x,z1,y,ONE,VNULL); + if ( zv_norm2(zv_sub(u,z,u)) >= MACHEPS*x->dim ) + errmesg("zv_linlist()"); +#endif + + MEMCHK(); + + /* vector norms */ + notice("vector norms"); + x = zv_resize(x,12); + zv_rand(x); + for ( i = 0; i < x->dim; i++ ) + if ( zabs(v_entry(x,i)) >= 0.7 ) + v_set_val(x,i,ONE); + else + v_set_val(x,i,zneg(ONE)); + s1 = zv_norm1(x); + s2 = zv_norm2(x); + s3 = zv_norm_inf(x); + if ( fabs(s1 - x->dim) >= MACHEPS*x->dim || + fabs(s2 - sqrt((double)(x->dim))) >= MACHEPS*x->dim || + fabs(s3 - 1.0) >= MACHEPS ) + errmesg("zv_norm1/2/_inf()"); + + /* test matrix multiply etc */ + notice("matrix multiply and invert"); + A = zm_resize(A,10,10); + B = zm_resize(B,10,10); + zm_rand(A); + zm_inverse(A,B); + zm_mlt(A,B,C); + for ( i = 0; i < C->m; i++ ) + m_set_val(C,i,i,zsub(m_entry(C,i,i),ONE)); + if ( zm_norm_inf(C) >= MACHEPS*zm_norm_inf(A)*zm_norm_inf(B)*5 ) + errmesg("zm_inverse()/zm_mlt()"); + + MEMCHK(); + + /* ... and adjoints */ + notice("adjoints and adjoint-multiplies"); + zm_adjoint(A,A); /* can do square matrices in situ */ + zmam_mlt(A,B,C); + for ( i = 0; i < C->m; i++ ) + m_set_val(C,i,i,zsub(m_entry(C,i,i),ONE)); + if ( zm_norm_inf(C) >= MACHEPS*zm_norm_inf(A)*zm_norm_inf(B)*5 ) + errmesg("zm_adjoint()/zmam_mlt()"); + zm_adjoint(A,A); + zm_adjoint(B,B); + zmma_mlt(A,B,C); + for ( i = 0; i < C->m; i++ ) + m_set_val(C,i,i,zsub(m_entry(C,i,i),ONE)); + if ( zm_norm_inf(C) >= MACHEPS*zm_norm_inf(A)*zm_norm_inf(B)*5 ) + errmesg("zm_adjoint()/zmma_mlt()"); + zsm_mlt(zmake(3.71,2.753),B,B); + zmma_mlt(A,B,C); + for ( i = 0; i < C->m; i++ ) + m_set_val(C,i,i,zsub(m_entry(C,i,i),zmake(3.71,-2.753))); + if ( zm_norm_inf(C) >= MACHEPS*zm_norm_inf(A)*zm_norm_inf(B)*5 ) + errmesg("szm_mlt()/zmma_mlt()"); + zm_adjoint(B,B); + zsm_mlt(zdiv(ONE,zmake(3.71,-2.753)),B,B); + + MEMCHK(); + + /* ... and matrix-vector multiplies */ + notice("matrix-vector multiplies"); + x = zv_resize(x,A->n); + y = zv_resize(y,A->m); + z = zv_resize(z,A->m); + u = zv_resize(u,A->n); + zv_rand(x); + zv_rand(y); + zmv_mlt(A,x,z); + z1 = zin_prod(y,z); + zvm_mlt(A,y,u); + z2 = zin_prod(u,x); + if ( zabs(zsub(z1,z2)) >= (MACHEPS*x->dim)*x->dim ) + { + errmesg("zmv_mlt()/zvm_mlt()"); + printf("# difference between inner products is %g\n", + zabs(zsub(z1,z2))); + } + zmv_mlt(B,z,u); + if ( zv_norm2(zv_sub(u,x,u)) >= MACHEPS*zm_norm_inf(A)*zm_norm_inf(B)*5 ) + errmesg("zmv_mlt()/zvm_mlt()"); + + MEMCHK(); + + /* get/set row/col */ + notice("getting and setting rows and cols"); + x = zv_resize(x,A->n); + y = zv_resize(y,B->m); + x = zget_row(A,3,x); + y = zget_col(B,3,y); + if ( zabs(zsub(_zin_prod(x,y,0,Z_NOCONJ),ONE)) >= + MACHEPS*zm_norm_inf(A)*zm_norm_inf(B)*5 ) + errmesg("zget_row()/zget_col()"); + zv_mlt(zmake(-1.0,0.0),x,x); + zv_mlt(zmake(-1.0,0.0),y,y); + zset_row(A,3,x); + zset_col(B,3,y); + zm_mlt(A,B,C); + for ( i = 0; i < C->m; i++ ) + m_set_val(C,i,i,zsub(m_entry(C,i,i),ONE)); + if ( zm_norm_inf(C) >= MACHEPS*zm_norm_inf(A)*zm_norm_inf(B)*5 ) + errmesg("zset_row()/zset_col()"); + + MEMCHK(); + + /* matrix norms */ + notice("matrix norms"); + A = zm_resize(A,11,15); + zm_rand(A); + s1 = zm_norm_inf(A); + B = zm_adjoint(A,B); + s2 = zm_norm1(B); + if ( fabs(s1 - s2) >= MACHEPS*A->m ) + errmesg("zm_norm1()/zm_norm_inf()"); + C = zmam_mlt(A,A,C); + z1.re = z1.im = 0.0; + for ( i = 0; i < C->m && i < C->n; i++ ) + z1 = zadd(z1,m_entry(C,i,i)); + if ( fabs(sqrt(z1.re) - zm_norm_frob(A)) >= MACHEPS*A->m*A->n ) + errmesg("zm_norm_frob"); + + MEMCHK(); + + /* permuting rows and columns */ + /****************************** + notice("permuting rows & cols"); + A = zm_resize(A,11,15); + B = zm_resize(B,11,15); + pi1 = px_resize(pi1,A->m); + px_rand(pi1); + x = zv_resize(x,A->n); + y = zmv_mlt(A,x,y); + px_rows(pi1,A,B); + px_zvec(pi1,y,z); + zmv_mlt(B,x,u); + if ( zv_norm2(zv_sub(z,u,u)) >= MACHEPS*A->m ) + errmesg("px_rows()"); + pi1 = px_resize(pi1,A->n); + px_rand(pi1); + px_cols(pi1,A,B); + pxinv_zvec(pi1,x,z); + zmv_mlt(B,z,u); + if ( zv_norm2(zv_sub(y,u,u)) >= MACHEPS*A->n ) + errmesg("px_cols()"); + ******************************/ + + MEMCHK(); + + /* MATLAB save/load */ + notice("MATLAB save/load"); + A = zm_resize(A,12,11); + if ( (fp=fopen(SAVE_FILE,"w")) == (FILE *)NULL ) + printf("Cannot perform MATLAB save/load test\n"); + else + { + zm_rand(A); + zm_save(fp, A, name); + fclose(fp); + if ( (fp=fopen(SAVE_FILE,"r")) == (FILE *)NULL ) + printf("Cannot open save file \"%s\"\n",SAVE_FILE); + else + { + ZM_FREE(B); + B = zm_load(fp,&cp); + if ( strcmp(name,cp) || zm_norm1(zm_sub(A,B,C)) >= + MACHEPS*A->m ) + { + errmesg("zm_load()/zm_save()"); + printf("# orig. name = %s, restored name = %s\n", name, cp); + printf("# orig. A =\n"); zm_output(A); + printf("# restored A =\n"); zm_output(B); + } + } + } + + MEMCHK(); + + /* Now, onto matrix factorisations */ + A = zm_resize(A,10,10); + B = zm_resize(B,A->m,A->n); + zm_copy(A,B); + x = zv_resize(x,A->n); + y = zv_resize(y,A->m); + z = zv_resize(z,A->n); + u = zv_resize(u,A->m); + zv_rand(x); + zmv_mlt(B,x,y); + z = zv_copy(x,z); + + notice("LU factor/solve"); + pivot = px_get(A->m); + zLUfactor(A,pivot); + tracecatch(zLUsolve(A,pivot,y,x),"main"); + tracecatch(cond_est = zLUcondest(A,pivot),"main"); + printf("# cond(A) approx= %g\n", cond_est); + if ( zv_norm2(zv_sub(x,z,u)) >= MACHEPS*zv_norm2(x)*cond_est) + { + errmesg("zLUfactor()/zLUsolve()"); + printf("# LU solution error = %g [cf MACHEPS = %g]\n", + zv_norm2(zv_sub(x,z,u)), MACHEPS); + } + + + zv_copy(y,x); + tracecatch(zLUsolve(A,pivot,x,x),"main"); + tracecatch(cond_est = zLUcondest(A,pivot),"main"); + if ( zv_norm2(zv_sub(x,z,u)) >= MACHEPS*zv_norm2(x)*cond_est) + { + errmesg("zLUfactor()/zLUsolve()"); + printf("# LU solution error = %g [cf MACHEPS = %g]\n", + zv_norm2(zv_sub(x,z,u)), MACHEPS); + } + + zvm_mlt(B,z,y); + zv_copy(y,x); + tracecatch(zLUAsolve(A,pivot,x,x),"main"); + if ( zv_norm2(zv_sub(x,z,u)) >= MACHEPS*zv_norm2(x)*cond_est) + { + errmesg("zLUfactor()/zLUAsolve()"); + printf("# LU solution error = %g [cf MACHEPS = %g]\n", + zv_norm2(zv_sub(x,z,u)), MACHEPS); + } + + MEMCHK(); + + /* QR factorisation */ + zm_copy(B,A); + zmv_mlt(B,z,y); + notice("QR factor/solve:"); + diag = zv_get(A->m); + zQRfactor(A,diag); + zQRsolve(A,diag,y,x); + if ( zv_norm2(zv_sub(x,z,u)) >= MACHEPS*zv_norm2(x)*cond_est ) + { + errmesg("zQRfactor()/zQRsolve()"); + printf("# QR solution error = %g [cf MACHEPS = %g]\n", + zv_norm2(zv_sub(x,z,u)), MACHEPS); + } + printf("# QR cond(A) approx= %g\n", zQRcondest(A)); + Q = zm_get(A->m,A->m); + zmakeQ(A,diag,Q); + zmakeR(A,A); + zm_mlt(Q,A,C); + zm_sub(B,C,C); + if ( zm_norm1(C) >= MACHEPS*zm_norm1(Q)*zm_norm1(B) ) + { + errmesg("zQRfactor()/zmakeQ()/zmakeR()"); + printf("# QR reconstruction error = %g [cf MACHEPS = %g]\n", + zm_norm1(C), MACHEPS); + } + + MEMCHK(); + + /* now try with a non-square matrix */ + A = zm_resize(A,15,7); + zm_rand(A); + B = zm_copy(A,B); + diag = zv_resize(diag,A->n); + x = zv_resize(x,A->n); + y = zv_resize(y,A->m); + zv_rand(y); + zQRfactor(A,diag); + x = zQRsolve(A,diag,y,x); + /* z is the residual vector */ + zmv_mlt(B,x,z); zv_sub(z,y,z); + /* check B*.z = 0 */ + zvm_mlt(B,z,u); + if ( zv_norm2(u) >= 100*MACHEPS*zm_norm1(B)*zv_norm2(y) ) + { + errmesg("zQRfactor()/zQRsolve()"); + printf("# QR solution error = %g [cf MACHEPS = %g]\n", + zv_norm2(u), MACHEPS); + } + Q = zm_resize(Q,A->m,A->m); + zmakeQ(A,diag,Q); + zmakeR(A,A); + zm_mlt(Q,A,C); + zm_sub(B,C,C); + if ( zm_norm1(C) >= MACHEPS*zm_norm1(Q)*zm_norm1(B) ) + { + errmesg("zQRfactor()/zmakeQ()/zmakeR()"); + printf("# QR reconstruction error = %g [cf MACHEPS = %g]\n", + zm_norm1(C), MACHEPS); + } + D = zm_get(A->m,Q->m); + zmam_mlt(Q,Q,D); + for ( i = 0; i < D->m; i++ ) + m_set_val(D,i,i,zsub(m_entry(D,i,i),ONE)); + if ( zm_norm1(D) >= MACHEPS*zm_norm1(Q)*zm_norm_inf(Q) ) + { + errmesg("QRfactor()/makeQ()/makeR()"); + printf("# QR orthogonality error = %g [cf MACHEPS = %g]\n", + zm_norm1(D), MACHEPS); + } + + MEMCHK(); + + /* QRCP factorisation */ + zm_copy(B,A); + notice("QR factor/solve with column pivoting"); + pivot = px_resize(pivot,A->n); + zQRCPfactor(A,diag,pivot); + z = zv_resize(z,A->n); + zQRCPsolve(A,diag,pivot,y,z); + /* pxinv_zvec(pivot,z,x); */ + /* now compute residual (z) vector */ + zmv_mlt(B,x,z); zv_sub(z,y,z); + /* check B^T.z = 0 */ + zvm_mlt(B,z,u); + if ( zv_norm2(u) >= MACHEPS*zm_norm1(B)*zv_norm2(y) ) + { + errmesg("QRCPfactor()/QRsolve()"); + printf("# QR solution error = %g [cf MACHEPS = %g]\n", + zv_norm2(u), MACHEPS); + } + + Q = zm_resize(Q,A->m,A->m); + zmakeQ(A,diag,Q); + zmakeR(A,A); + zm_mlt(Q,A,C); + ZM_FREE(D); + D = zm_get(B->m,B->n); + /****************************** + px_cols(pivot,C,D); + zm_sub(B,D,D); + if ( zm_norm1(D) >= MACHEPS*zm_norm1(Q)*zm_norm1(B) ) + { + errmesg("QRCPfactor()/makeQ()/makeR()"); + printf("# QR reconstruction error = %g [cf MACHEPS = %g]\n", + zm_norm1(D), MACHEPS); + } + ******************************/ + + /* Now check eigenvalue/SVD routines */ + notice("complex Schur routines"); + A = zm_resize(A,11,11); + B = zm_resize(B,A->m,A->n); + C = zm_resize(C,A->m,A->n); + D = zm_resize(D,A->m,A->n); + Q = zm_resize(Q,A->m,A->n); + + MEMCHK(); + + /* now test complex Schur decomposition */ + /* zm_copy(A,B); */ + ZM_FREE(A); + A = zm_get(11,11); + zm_rand(A); + B = zm_copy(A,B); + MEMCHK(); + + B = zschur(B,Q); + MEMCHK(); + + zm_mlt(Q,B,C); + zmma_mlt(C,Q,D); + MEMCHK(); + zm_sub(A,D,D); + if ( zm_norm1(D) >= MACHEPS*zm_norm1(Q)*zm_norm_inf(Q)*zm_norm1(B)*5 ) + { + errmesg("zschur()"); + printf("# Schur reconstruction error = %g [cf MACHEPS = %g]\n", + zm_norm1(D), MACHEPS); + } + + /* orthogonality check */ + zmma_mlt(Q,Q,D); + for ( i = 0; i < D->m; i++ ) + m_set_val(D,i,i,zsub(m_entry(D,i,i),ONE)); + if ( zm_norm1(D) >= MACHEPS*zm_norm1(Q)*zm_norm_inf(Q)*10 ) + { + errmesg("zschur()"); + printf("# Schur orthogonality error = %g [cf MACHEPS = %g]\n", + zm_norm1(D), MACHEPS); + } + + MEMCHK(); + + /* now test SVD */ + /****************************** + A = zm_resize(A,11,7); + zm_rand(A); + U = zm_get(A->n,A->n); + Q = zm_resize(Q,A->m,A->m); + u = zv_resize(u,max(A->m,A->n)); + svd(A,Q,U,u); + ******************************/ + /* check reconstruction of A */ + /****************************** + D = zm_resize(D,A->m,A->n); + C = zm_resize(C,A->m,A->n); + zm_zero(D); + for ( i = 0; i < min(A->m,A->n); i++ ) + zm_set_val(D,i,i,v_entry(u,i)); + zmam_mlt(Q,D,C); + zm_mlt(C,U,D); + zm_sub(A,D,D); + if ( zm_norm1(D) >= MACHEPS*zm_norm1(U)*zm_norm_inf(Q)*zm_norm1(A) ) + { + errmesg("svd()"); + printf("# SVD reconstruction error = %g [cf MACHEPS = %g]\n", + zm_norm1(D), MACHEPS); + } + ******************************/ + /* check orthogonality of Q and U */ + /****************************** + D = zm_resize(D,Q->n,Q->n); + zmam_mlt(Q,Q,D); + for ( i = 0; i < D->m; i++ ) + m_set_val(D,i,i,m_entry(D,i,i)-1.0); + if ( zm_norm1(D) >= MACHEPS*zm_norm1(Q)*zm_norm_inf(Q)*5 ) + { + errmesg("svd()"); + printf("# SVD orthognality error (Q) = %g [cf MACHEPS = %g\n", + zm_norm1(D), MACHEPS); + } + D = zm_resize(D,U->n,U->n); + zmam_mlt(U,U,D); + for ( i = 0; i < D->m; i++ ) + m_set_val(D,i,i,m_entry(D,i,i)-1.0); + if ( zm_norm1(D) >= MACHEPS*zm_norm1(U)*zm_norm_inf(U)*5 ) + { + errmesg("svd()"); + printf("# SVD orthognality error (U) = %g [cf MACHEPS = %g\n", + zm_norm1(D), MACHEPS); + } + for ( i = 0; i < u->dim; i++ ) + if ( v_entry(u,i) < 0 || (i < u->dim-1 && + v_entry(u,i+1) > v_entry(u,i)) ) + break; + if ( i < u->dim ) + { + errmesg("svd()"); + printf("# SVD sorting error\n"); + } + ******************************/ + + ZV_FREE(x); ZV_FREE(y); ZV_FREE(z); + ZV_FREE(u); ZV_FREE(diag); + PX_FREE(pi1); PX_FREE(pi2); PX_FREE(pivot); + ZM_FREE(A); ZM_FREE(B); ZM_FREE(C); + ZM_FREE(D); ZM_FREE(Q); + + mem_stat_free(1); + + MEMCHK(); + printf("# Finished torture test for complex numbers/vectors/matrices\n"); + mem_info(); +} + diff --git a/meschach/zvecop.c b/meschach/zvecop.c new file mode 100644 index 0000000..b10bfee --- /dev/null +++ b/meschach/zvecop.c @@ -0,0 +1,510 @@ + +/************************************************************************** +** +** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. +** +** Meschach Library +** +** This Meschach Library is provided "as is" without any express +** or implied warranty of any kind with respect to this software. +** In particular the authors shall not be liable for any direct, +** indirect, special, incidental or consequential damages arising +** in any way from use of the software. +** +** Everyone is granted permission to copy, modify and redistribute this +** Meschach Library, provided: +** 1. All copies contain this copyright notice. +** 2. All modified copies shall carry a notice stating who +** made the last modification and the date of such modification. +** 3. No charge is made for this software or works derived from it. +** This clause shall not be construed as constraining other software +** distributed on the same medium as this software, nor is a +** distribution fee considered a charge. +** +***************************************************************************/ + + +#include +#include "matrix.h" +#include "zmatrix.h" +static char rcsid[] = "$Id: zvecop.c,v 1.1 2001/03/01 17:19:26 rfranke Exp $"; + + + +/* _zin_prod -- inner product of two vectors from i0 downwards + -- flag != 0 means compute sum_i a[i]*.b[i]; + -- flag == 0 means compute sum_i a[i].b[i] */ +complex _zin_prod(a,b,i0,flag) +ZVEC *a,*b; +u_int i0, flag; +{ + u_int limit; + + if ( a==ZVNULL || b==ZVNULL ) + error(E_NULL,"_zin_prod"); + limit = min(a->dim,b->dim); + if ( i0 > limit ) + error(E_BOUNDS,"_zin_prod"); + + return __zip__(&(a->ve[i0]),&(b->ve[i0]),(int)(limit-i0),flag); +} + +/* zv_mlt -- scalar-vector multiply -- may be in-situ */ +ZVEC *zv_mlt(scalar,vector,out) +complex scalar; +ZVEC *vector,*out; +{ + /* u_int dim, i; */ + /* complex *out_ve, *vec_ve; */ + + if ( vector==ZVNULL ) + error(E_NULL,"zv_mlt"); + if ( out==ZVNULL || out->dim != vector->dim ) + out = zv_resize(out,vector->dim); + if ( scalar.re == 0.0 && scalar.im == 0.0 ) + return zv_zero(out); + if ( scalar.re == 1.0 && scalar.im == 0.0 ) + return zv_copy(vector,out); + + __zmlt__(vector->ve,scalar,out->ve,(int)(vector->dim)); + + return (out); +} + +/* zv_add -- vector addition -- may be in-situ */ +ZVEC *zv_add(vec1,vec2,out) +ZVEC *vec1,*vec2,*out; +{ + u_int dim; + + if ( vec1==ZVNULL || vec2==ZVNULL ) + error(E_NULL,"zv_add"); + if ( vec1->dim != vec2->dim ) + error(E_SIZES,"zv_add"); + if ( out==ZVNULL || out->dim != vec1->dim ) + out = zv_resize(out,vec1->dim); + dim = vec1->dim; + __zadd__(vec1->ve,vec2->ve,out->ve,(int)dim); + + return (out); +} + +/* zv_mltadd -- scalar/vector multiplication and addition + -- out = v1 + scale.v2 */ +ZVEC *zv_mltadd(v1,v2,scale,out) +ZVEC *v1,*v2,*out; +complex scale; +{ + /* register u_int dim, i; */ + /* complex *out_ve, *v1_ve, *v2_ve; */ + + if ( v1==ZVNULL || v2==ZVNULL ) + error(E_NULL,"zv_mltadd"); + if ( v1->dim != v2->dim ) + error(E_SIZES,"zv_mltadd"); + if ( scale.re == 0.0 && scale.im == 0.0 ) + return zv_copy(v1,out); + if ( scale.re == 1.0 && scale.im == 0.0 ) + return zv_add(v1,v2,out); + + if ( v2 != out ) + { + tracecatch(out = zv_copy(v1,out),"zv_mltadd"); + + /* dim = v1->dim; */ + __zmltadd__(out->ve,v2->ve,scale,(int)(v1->dim),0); + } + else + { + tracecatch(out = zv_mlt(scale,v2,out),"zv_mltadd"); + out = zv_add(v1,out,out); + } + + return (out); +} + +/* zv_sub -- vector subtraction -- may be in-situ */ +ZVEC *zv_sub(vec1,vec2,out) +ZVEC *vec1,*vec2,*out; +{ + /* u_int i, dim; */ + /* complex *out_ve, *vec1_ve, *vec2_ve; */ + + if ( vec1==ZVNULL || vec2==ZVNULL ) + error(E_NULL,"zv_sub"); + if ( vec1->dim != vec2->dim ) + error(E_SIZES,"zv_sub"); + if ( out==ZVNULL || out->dim != vec1->dim ) + out = zv_resize(out,vec1->dim); + + __zsub__(vec1->ve,vec2->ve,out->ve,(int)(vec1->dim)); + + return (out); +} + +/* zv_map -- maps function f over components of x: out[i] = f(x[i]) + -- _zv_map sets out[i] = f(x[i],params) */ +ZVEC *zv_map(f,x,out) +#ifdef PROTOYPES_IN_STRUCT +complex (*f)(complex); +#else +complex (*f)(); +#endif +ZVEC *x, *out; +{ + complex *x_ve, *out_ve; + int i, dim; + + if ( ! x || ! f ) + error(E_NULL,"zv_map"); + if ( ! out || out->dim != x->dim ) + out = zv_resize(out,x->dim); + + dim = x->dim; x_ve = x->ve; out_ve = out->ve; + for ( i = 0; i < dim; i++ ) + out_ve[i] = (*f)(x_ve[i]); + + return out; +} + +ZVEC *_zv_map(f,params,x,out) +#ifdef PROTOTYPES_IN_STRUCT +complex (*f)(void *,complex); +#else +complex (*f)(); +#endif +ZVEC *x, *out; +void *params; +{ + complex *x_ve, *out_ve; + int i, dim; + + if ( ! x || ! f ) + error(E_NULL,"_zv_map"); + if ( ! out || out->dim != x->dim ) + out = zv_resize(out,x->dim); + + dim = x->dim; x_ve = x->ve; out_ve = out->ve; + for ( i = 0; i < dim; i++ ) + out_ve[i] = (*f)(params,x_ve[i]); + + return out; +} + +/* zv_lincomb -- returns sum_i a[i].v[i], a[i] real, v[i] vectors */ +ZVEC *zv_lincomb(n,v,a,out) +int n; /* number of a's and v's */ +complex a[]; +ZVEC *v[], *out; +{ + int i; + + if ( ! a || ! v ) + error(E_NULL,"zv_lincomb"); + if ( n <= 0 ) + return ZVNULL; + + for ( i = 1; i < n; i++ ) + if ( out == v[i] ) + error(E_INSITU,"zv_lincomb"); + + out = zv_mlt(a[0],v[0],out); + for ( i = 1; i < n; i++ ) + { + if ( ! v[i] ) + error(E_NULL,"zv_lincomb"); + if ( v[i]->dim != out->dim ) + error(E_SIZES,"zv_lincomb"); + out = zv_mltadd(out,v[i],a[i],out); + } + + return out; +} + + +#ifdef ANSI_C + + +/* zv_linlist -- linear combinations taken from a list of arguments; + calling: + zv_linlist(out,v1,a1,v2,a2,...,vn,an,NULL); + where vi are vectors (ZVEC *) and ai are numbers (complex) +*/ + +ZVEC *zv_linlist(ZVEC *out,ZVEC *v1,complex a1,...) +{ + va_list ap; + ZVEC *par; + complex a_par; + + if ( ! v1 ) + return ZVNULL; + + va_start(ap, a1); + out = zv_mlt(a1,v1,out); + + while (par = va_arg(ap,ZVEC *)) { /* NULL ends the list*/ + a_par = va_arg(ap,complex); + if (a_par.re == 0.0 && a_par.im == 0.0) continue; + if ( out == par ) + error(E_INSITU,"zv_linlist"); + if ( out->dim != par->dim ) + error(E_SIZES,"zv_linlist"); + + if (a_par.re == 1.0 && a_par.im == 0.0) + out = zv_add(out,par,out); + else if (a_par.re == -1.0 && a_par.im == 0.0) + out = zv_sub(out,par,out); + else + out = zv_mltadd(out,par,a_par,out); + } + + va_end(ap); + return out; +} + + +#elif VARARGS + +/* zv_linlist -- linear combinations taken from a list of arguments; + calling: + zv_linlist(out,v1,a1,v2,a2,...,vn,an,NULL); + where vi are vectors (ZVEC *) and ai are numbers (complex) +*/ +ZVEC *zv_linlist(va_alist) va_dcl +{ + va_list ap; + ZVEC *par, *out; + complex a_par; + + va_start(ap); + out = va_arg(ap,ZVEC *); + par = va_arg(ap,ZVEC *); + if ( ! par ) { + va_end(ap); + return ZVNULL; + } + + a_par = va_arg(ap,complex); + out = zv_mlt(a_par,par,out); + + while (par = va_arg(ap,ZVEC *)) { /* NULL ends the list*/ + a_par = va_arg(ap,complex); + if (a_par.re == 0.0 && a_par.im == 0.0) continue; + if ( out == par ) + error(E_INSITU,"zv_linlist"); + if ( out->dim != par->dim ) + error(E_SIZES,"zv_linlist"); + + if (a_par.re == 1.0 && a_par.im == 0.0) + out = zv_add(out,par,out); + else if (a_par.re == -1.0 && a_par.im == 0.0) + out = zv_sub(out,par,out); + else + out = zv_mltadd(out,par,a_par,out); + } + + va_end(ap); + return out; +} + + +#endif + + + +/* zv_star -- computes componentwise (Hadamard) product of x1 and x2 + -- result out is returned */ +ZVEC *zv_star(x1, x2, out) +ZVEC *x1, *x2, *out; +{ + int i; + Real t_re, t_im; + + if ( ! x1 || ! x2 ) + error(E_NULL,"zv_star"); + if ( x1->dim != x2->dim ) + error(E_SIZES,"zv_star"); + out = zv_resize(out,x1->dim); + + for ( i = 0; i < x1->dim; i++ ) + { + /* out->ve[i] = x1->ve[i] * x2->ve[i]; */ + t_re = x1->ve[i].re*x2->ve[i].re - x1->ve[i].im*x2->ve[i].im; + t_im = x1->ve[i].re*x2->ve[i].im + x1->ve[i].im*x2->ve[i].re; + out->ve[i].re = t_re; + out->ve[i].im = t_im; + } + + return out; +} + +/* zv_slash -- computes componentwise ratio of x2 and x1 + -- out[i] = x2[i] / x1[i] + -- if x1[i] == 0 for some i, then raise E_SING error + -- result out is returned */ +ZVEC *zv_slash(x1, x2, out) +ZVEC *x1, *x2, *out; +{ + int i; + Real r2, t_re, t_im; + complex tmp; + + if ( ! x1 || ! x2 ) + error(E_NULL,"zv_slash"); + if ( x1->dim != x2->dim ) + error(E_SIZES,"zv_slash"); + out = zv_resize(out,x1->dim); + + for ( i = 0; i < x1->dim; i++ ) + { + r2 = x1->ve[i].re*x1->ve[i].re + x1->ve[i].im*x1->ve[i].im; + if ( r2 == 0.0 ) + error(E_SING,"zv_slash"); + tmp.re = x1->ve[i].re / r2; + tmp.im = - x1->ve[i].im / r2; + t_re = tmp.re*x2->ve[i].re - tmp.im*x2->ve[i].im; + t_im = tmp.re*x2->ve[i].im - tmp.im*x2->ve[i].re; + out->ve[i].re = t_re; + out->ve[i].im = t_im; + } + + return out; +} + +/* zv_sum -- returns sum of entries of a vector */ +complex zv_sum(x) +ZVEC *x; +{ + int i; + complex sum; + + if ( ! x ) + error(E_NULL,"zv_sum"); + + sum.re = sum.im = 0.0; + for ( i = 0; i < x->dim; i++ ) + { + sum.re += x->ve[i].re; + sum.im += x->ve[i].im; + } + + return sum; +} + +/* px_zvec -- permute vector */ +ZVEC *px_zvec(px,vector,out) +PERM *px; +ZVEC *vector,*out; +{ + u_int old_i, i, size, start; + complex tmp; + + if ( px==PNULL || vector==ZVNULL ) + error(E_NULL,"px_zvec"); + if ( px->size > vector->dim ) + error(E_SIZES,"px_zvec"); + if ( out==ZVNULL || out->dim < vector->dim ) + out = zv_resize(out,vector->dim); + + size = px->size; + if ( size == 0 ) + return zv_copy(vector,out); + + if ( out != vector ) + { + for ( i=0; ipe[i] >= size ) + error(E_BOUNDS,"px_vec"); + else + out->ve[i] = vector->ve[px->pe[i]]; + } + else + { /* in situ algorithm */ + start = 0; + while ( start < size ) + { + old_i = start; + i = px->pe[old_i]; + if ( i >= size ) + { + start++; + continue; + } + tmp = vector->ve[start]; + while ( TRUE ) + { + vector->ve[old_i] = vector->ve[i]; + px->pe[old_i] = i+size; + old_i = i; + i = px->pe[old_i]; + if ( i >= size ) + break; + if ( i == start ) + { + vector->ve[old_i] = tmp; + px->pe[old_i] = i+size; + break; + } + } + start++; + } + + for ( i = 0; i < size; i++ ) + if ( px->pe[i] < size ) + error(E_BOUNDS,"px_vec"); + else + px->pe[i] = px->pe[i]-size; + } + + return out; +} + +/* pxinv_zvec -- apply the inverse of px to x, returning the result in out + -- may NOT be in situ */ +ZVEC *pxinv_zvec(px,x,out) +PERM *px; +ZVEC *x, *out; +{ + u_int i, size; + + if ( ! px || ! x ) + error(E_NULL,"pxinv_zvec"); + if ( px->size > x->dim ) + error(E_SIZES,"pxinv_zvec"); + if ( ! out || out->dim < x->dim ) + out = zv_resize(out,x->dim); + + size = px->size; + if ( size == 0 ) + return zv_copy(x,out); + if ( out != x ) + { + for ( i=0; ipe[i] >= size ) + error(E_BOUNDS,"pxinv_vec"); + else + out->ve[px->pe[i]] = x->ve[i]; + } + else + { /* in situ algorithm --- cheat's way out */ + px_inv(px,px); + px_zvec(px,x,out); + px_inv(px,px); + } + + + return out; +} + +/* zv_rand -- randomise a complex vector; uniform in [0,1)+[0,1)*i */ +ZVEC *zv_rand(x) +ZVEC *x; +{ + if ( ! x ) + error(E_NULL,"zv_rand"); + + mrandlist((Real *)(x->ve),2*x->dim); + + return x; +} diff --git a/odc/Makefile.in b/odc/Makefile.in new file mode 100644 index 0000000..849bcf4 --- /dev/null +++ b/odc/Makefile.in @@ -0,0 +1,92 @@ +# +# Makefile for the package Odc +# + +include ../makedirs + +O = @OBJ_SUFFIX@ + +.SUFFIXES: .c .C @OBJ_SUFFIX@ @LIB_SUFFIX@ + +# +# machine dependencies +# + +# +# additional objects to create an executable +# +FORTRAN_LIBS = @FORTRAN_LIBS@ +MACH_OBJS = @TCL_LIBS@ $(FORTRAN_LIBS) -lm + +LFLAG = @LFLAG@ +# +# flag to add a path for the run-time loader +# (e.g. -R -Wl,-rpath, -Wl,+b,) +# -- or just use $LFLAG resulting in no run-path +# and make libtcl, libhqp, and libomu known through +# the environment variable LD_LIBRARY_PATH -- +RFLAG = @RFLAG@ + +# +# paths +# +OMU_PREFIX = @prefix@ + +OMU_INCDIR = -I../meschach -I../iftcl -I../hqp -I../adol-c/SRC -I../omu \ + -I${OMU_PREFIX}/include/omuses + +OMU_LIBDIR = -L../lib $(RFLAG)../lib \ + -L${OMU_PREFIX}/lib $(RFLAG)${OMU_PREFIX}/lib + +# +# compiler and flags +# + +CXX = @CXX@ +CC = @CC@ + +CFLAGS = @GFLAG@ @WFLAG@ -DDEBUG \ + ${OMU_INCDIR} ${TCL_INCDIR} + +LDFLAGS = ${OMU_LIBDIR} ${TCL_LIBDIR} + +# +# machine independent part +# + +GMALLOC_O = @GMALLOC_O@ + +SRCS = Odc_Init.C \ + Prg_Crane.C \ + Prg_CranePar.C \ + Prg_Maratos.C \ + Prg_HS99omu.C \ + Prg_HS99.C \ + Prg_TP383omu.C \ + Prg_TP383.C + +OBJS = $(SRCS:.C=.o) Odc_Main.o $(GMALLOC_O) + +RESULT = odc + +all: $(OBJS) Makefile + $(CXX) -o $(RESULT) $(LDFLAGS) $(OBJS) \ + -lomu -lhqp $(MACH_OBJS) + +gmalloc $(GMALLOC_O): $(GMALLOC_O:.o=.c) + PWD=`pwd`; cd `dirname $(GMALLOC_O)`; \ + make `basename $(GMALLOC_O)`; cd $(PWD) + +.C.o: + $(CXX) -c $(CFLAGS) $< + +.c.o: + $(CC) -c $(CFLAGS) $< + +clean: + rm -f $(RESULT)@EXE_SUFFIX@ *.o *.obj *~ *core control.plt + +depend: + makedepend -- $(CFLAGS) -- $(SRCS) + +# DO NOT DELETE THIS LINE -- make depend depends on it. diff --git a/odc/Odc_Init.C b/odc/Odc_Init.C new file mode 100644 index 0000000..f2fd196 --- /dev/null +++ b/odc/Odc_Init.C @@ -0,0 +1,27 @@ +/* + * Odc_Init: initialize the package Odc (Omuses demo collection) + * + * rf, 1/14/97 + */ + +#include +#include + +//-------------------------------------------------------------------------- +const char *Odc_Version = "1.2"; + +static int Odc_VersionCmd(int, char *[], char **result) +{ + *result = (char *)Odc_Version; + return IF_OK; +} + +//-------------------------------------------------------------------------- +extern "C" int Odc_Init(Tcl_Interp *interp) +{ + // do package specific initializations + + new If_Proc("odc_version", &Odc_VersionCmd); + + return TCL_OK; +} diff --git a/odc/Odc_Main.c b/odc/Odc_Main.c new file mode 100644 index 0000000..f4b08cb --- /dev/null +++ b/odc/Odc_Main.c @@ -0,0 +1,64 @@ +/* + * Odc_Main.c -- + * + * main function for the Omuses demo collection + * (this file may be replaced by tclAppInit.c or tkAppInit.c of + * a Tcl/Tk distribution, provided that the modules Hqp, Omu, + * and Odc are initialized) + * + * rf, 2/6/97 + */ + +#include + +/* + * prototypes for module initializations + */ + +int Hqp_Init _ANSI_ARGS_((Tcl_Interp *interp)); +int Omu_Init _ANSI_ARGS_((Tcl_Interp *interp)); +int Odc_Init _ANSI_ARGS_((Tcl_Interp *interp)); + +/* + * the main function + */ + +int +main(argc, argv) + int argc; + char **argv; +{ + Tcl_Main(argc, argv, Tcl_AppInit); + return 0; +} + +/* + * Tcl_AppInit function + */ + +int +Tcl_AppInit(interp) + Tcl_Interp *interp; +{ + if (Tcl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + + if (Hqp_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + Tcl_StaticPackage(interp, "Hqp", Hqp_Init, NULL); + + if (Omu_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + Tcl_StaticPackage(interp, "Omu", Omu_Init, NULL); + + if (Odc_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + Tcl_StaticPackage(interp, "Odc", Odc_Init, NULL); + + Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY); + return TCL_OK; +} diff --git a/odc/Prg_Crane.C b/odc/Prg_Crane.C new file mode 100644 index 0000000..53d25c2 --- /dev/null +++ b/odc/Prg_Crane.C @@ -0,0 +1,205 @@ +/* + * Prg_Crane.C -- class definition + * + * rf, 7/15/96 + */ + +#include + +#include "Prg_Crane.h" + +#include +#include + +IF_CLASS_DEFINE("Crane", Prg_Crane, Omu_Program); + +//-------------------------------------------------------------------------- +Prg_Crane::Prg_Crane() +{ + _K = 50; + _tf_guess = 15.0; + _u_bound = 5.0; + _phi_bound = 5.0 / 180.0 * 3.14159; + _bound_init = false; + + _nx = 6; + _nu = 1; + offs = 1; // for the final time parameter + + _ifList.append(new If_Float("prg_tf_guess", &_tf_guess)); + _ifList.append(new If_Float("prg_u_bound", &_u_bound)); + _ifList.append(new If_Float("prg_phi_bound", &_phi_bound)); + _ifList.append(new If_Bool("prg_bound_init", &_bound_init)); + + // default values for parameters + Fscale = 1000.0; + g = 9.81; + l = 10.0; + md = 1000.0; + ml = 4000.0; + + // interface elements for unbound variables + _ifList.append(new If_Float("prg_Fscale", &Fscale)); + _ifList.append(new If_Float("prg_g", &g)); + _ifList.append(new If_Float("prg_l", &l)); + _ifList.append(new If_Float("prg_md", &md)); + _ifList.append(new If_Float("prg_ml", &ml)); +} + +//-------------------------------------------------------------------------- +void Prg_Crane::setup_stages(IVECP ks, VECP ts) +{ + stages_alloc(ks, ts, _K, 1, 0.0, 1.0); +} + +//-------------------------------------------------------------------------- +void Prg_Crane::setup(int k, + Omu_Vector &x, Omu_Vector &u, Omu_Vector &c) +{ + double u_guess; + + x.alloc(_nx); + if (k < _K) + u.alloc(_nu); + + if (k == 0) { + // bound parameters and implicit discrete part + mdl = md + ml; + + // initial state constraints + x.min[offs+0] = x.max[offs+0] = 0.0; // phi + x.min[offs+1] = x.max[offs+1] = 0.0; // omega + x.min[offs+2] = x.max[offs+2] = 0.0; // v + x.min[offs+3] = x.max[offs+3] = 25.0; // s + + // initial states + x.initial[offs+0] = 0.0; // phi + x.initial[offs+1] = 0.0; // omega + x.initial[offs+2] = 0.0; // v + x.initial[offs+3] = 25.0; // s + } + else if (k == _K) { + // final state constraints + x.min[offs+0] = x.max[offs+0] = 0.0; // phi + x.min[offs+1] = x.max[offs+1] = 0.0; // omega + x.min[offs+2] = x.max[offs+2] = 0.0; // v + x.min[offs+3] = x.max[offs+3] = 0.0; // s + } + else { + // bounds for phi + x.min[offs+0] = -_phi_bound; + x.max[offs+0] = _phi_bound; + + // bounds for s + x.min[offs+3] = 0.0; + x.max[offs+3] = 25.0; + } + + // lower bound on the final time + x.min[0] = 1.0; + + // control bounds + x.min[5] = -_u_bound; + x.max[5] = _u_bound; + + // + // init solution + // + + x.initial[0] = _tf_guess; + + if (k < _K/2) + u_guess = -100.0 * mdl / Fscale / (_tf_guess*_tf_guess); + else + u_guess = 100.0 * mdl / Fscale / (_tf_guess*_tf_guess); + + x.initial[5] = u_guess; + + if (k < _K) { + if (k <= _K/2 && k+1 > _K/2) + u.initial[0] = 2.0 * u_guess / (_tf_guess / (double)_K); + else + u.initial[0] = 0.0; + } +} + +//-------------------------------------------------------------------------- +void Prg_Crane::init_simulation(int k, + Omu_Vector &x, Omu_Vector &u) +{ + int i; + + // set initial states for the first stage; + // afterwards simulation results of the preceding stage are used + if (k == 0) { + for (i = 0; i < _nx; i++) + x[i] = x.initial[i]; + } + + // set the initial control for each stage + if (k < _K) + u[0] = u.initial[0]; + + // apply bounds to simulated states + if (_bound_init) { + for (i = 0; i < _nx; i++) { + x[i] = fmin(x[i], x.max[i]); + x[i] = fmax(x[i], x.min[i]); + } + } +} + +//-------------------------------------------------------------------------- +void Prg_Crane::update(int kk, + const adoublev &x, const adoublev &u, + adoublev &f, adouble &f0, adoublev &c) +{ + if (kk < _KK) + f[0] = x[0]; // constant final time + else + f0 = x[0]; // optimization criterion +} + +//-------------------------------------------------------------------------- +void Prg_Crane::continuous(int kk, double t, + const adoublev &x, const adoublev &u, + const adoublev &xp, adoublev &F) +{ + adouble tscale; + + tscale = x[0]; + model_eq(kk, value(tscale) * t, x, u, F); + for (int i = offs; i < _nx; i++) { + F[i] = tscale * F[i] - xp[i]; + } +} + +//-------------------------------------------------------------------------- +void Prg_Crane::model_eq(int kk, double t, + const adoublev &x, const adoublev &u, + adoublev &xp) +{ + // dynamic model variables + adouble den, omega, phi, s, sinphi, u_control, v; + + // state assignments + phi = x[offs+0]; + omega = x[offs+1]; + v = x[offs+2]; + s = x[offs+3]; + + // piecewise linear control + xp[5] = u[0]; + u_control = x[5]; + + // dynamic model equations + //u_control = u[0]; + sinphi = sin(phi); + den = md + ml*pow(sinphi, 2); + xp[offs+0] = omega; + xp[offs+1] = -(mdl*g*sinphi + 0.5*ml*l*pow(omega, 2)*sin(2*phi) + u_control*Fscale*cos(phi))/(l*den); + xp[offs+2] = (0.5*ml*g*sin(2*phi) + ml*l*pow(omega, 2)*sinphi + u_control*Fscale)/den; + xp[offs+3] = v; +} + +//========================================================================== diff --git a/odc/Prg_Crane.h b/odc/Prg_Crane.h new file mode 100644 index 0000000..f6e55b2 --- /dev/null +++ b/odc/Prg_Crane.h @@ -0,0 +1,63 @@ +/* + * Prg_Crane.h -- + * - crane according to the laboratory Opt3 + * + * rf, 1/15/97 + */ + +#ifndef Prg_Crane_H +#define Prg_Crane_H + +#include + +//-------------------------------------------------------------------------- +class Prg_Crane: public Omu_Program { + + protected: + + double _tf_guess; // initial guess for the final time + double _u_bound; // bound on the control variable + double _phi_bound; // bound on the angle state + bool _bound_init; // apply bound constraints to initial states + + void setup_stages(IVECP ks, VECP ts); + + void setup(int k, + Omu_Vector &x, Omu_Vector &u, Omu_Vector &c); + + void init_simulation(int k, + Omu_Vector &x, Omu_Vector &u); + + void update(int kk, + const adoublev &x, const adoublev &u, + adoublev &f, adouble &f0, adoublev &c); + + void continuous(int kk, double t, + const adoublev &x, const adoublev &u, const adoublev &xp, + adoublev &F); + + void model_eq(int kk, double t, + const adoublev &x, const adoublev &u, + adoublev &xp); + + int _nx; // number of states + int _nu; // number of control parameters + int offs; // offset for the automatically generated equations + + // model inputs and parameters + double Fscale; + double g; + double l; + double md; + double mdl; + double ml; + + public: + + Prg_Crane(); + + char *name() {return "Crane";} +}; + +#endif + diff --git a/odc/Prg_CranePar.C b/odc/Prg_CranePar.C new file mode 100644 index 0000000..b91205c --- /dev/null +++ b/odc/Prg_CranePar.C @@ -0,0 +1,206 @@ +/* + * Prg_CranePar.C -- class definition + * + * rf, 1/15/97 + */ + +#include + +#include "Prg_CranePar.h" + +#include +#include +#include +#include +#include + +IF_CLASS_DEFINE("CranePar", Prg_CranePar, Omu_Program); + +typedef If_Method If_Cmd; + +//-------------------------------------------------------------------------- +Prg_CranePar::Prg_CranePar() +{ + _nx = 5; // 4 states plus the mass parameter + offs = 1; // for the container mass parameter + _KK = 1; + + _maxdev = 0.05; + _seed = 1234; + _s_ref = v_get(_KK + 1); + _multistage = true; + + _ifList.append(new If_FloatVec("prg_s_ref", &_s_ref)); + _ifList.append(new If_Int("prg_seed", &_seed)); + _ifList.append(new If_Float("prg_maxdev", &_maxdev)); + _ifList.append(new If_Bool("prg_multistage", &_multistage)); + _ifList.append(new If_Cmd("prg_disturb", &Prg_CranePar::disturb, this)); + + // default values for parameters + Fscale = 1000.0; + g = 9.81; + l = 10.0; + md = 1000.0; + ml = 4000.0; + + // interface elements for unbound variables + _ifList.append(new If_Float("prg_Fscale", &Fscale)); + _ifList.append(new If_Float("prg_g", &g)); + _ifList.append(new If_Float("prg_l", &l)); + _ifList.append(new If_Float("prg_md", &md)); + _ifList.append(new If_Float("prg_ml", &ml)); +} + +//-------------------------------------------------------------------------- +Prg_CranePar::~Prg_CranePar() +{ + v_free(_s_ref); +} + +//-------------------------------------------------------------------------- +void Prg_CranePar::setup_stages(IVECP ks, VECP ts) +{ + if (_multistage) { + _K = _KK; + stages_alloc(ks, ts, _K, 1); + } + else { + _K = 1; + stages_alloc(ks, ts, 1, _KK); + } + + // resize the vectors for measurement data + v_resize(_s_ref, _KK + 1); +} + +//-------------------------------------------------------------------------- +void Prg_CranePar::setup(int k, + Omu_Vector &x, Omu_Vector &u, Omu_Vector &c) +{ + // allocate and initialize the free variables + if (k == 0) { + x.alloc(_nx); + + // bound parameters and implicit discrete part + // (this calculation is redefined with adoubles in model_eq()) + mdl = md + ml; + + // initial guess for the mass + x.initial[0] = ml / 1000.0; + + // initial states + x.initial[offs+0] = 0.0; // phi + x.initial[offs+1] = 0.0; // omega + x.initial[offs+2] = 0.0; // v + x.initial[offs+3] = 25.0; // s + } + + // allocate additional state variables in the multistage case + else if (_multistage) { + x.alloc(_nx); + } +} + +//-------------------------------------------------------------------------- +int Prg_CranePar::disturb(IF_CMD_ARGS) +{ + // disturb the recorded data once during the problem setup + int i, i_end, r; + i_end = _s_ref->dim; + + srand((unsigned int)_seed); + for (i = 0; i < i_end; i++) { + _s_ref[i] += _maxdev * ((double)rand() / (double)RAND_MAX * 2.0 - 1.0); + } + + return IF_OK; +} + +//-------------------------------------------------------------------------- +void Prg_CranePar::update(int kk, + const adoublev &x, const adoublev &u, + adoublev &f, adouble &f0, adoublev &c) +{ + adouble s; + + // discrete-time state equation for the mass parameter + if (kk < _KK) + f[0] = x[0]; + + if (_multistage) { + // + // We have an optimization problem with one stage for each measurement + // point (_K == _KK). This results in 5*(_KK+1) optimization variables. + // The criterion is defined as function of the optimization variable + // that describes the state s in each stage. + // + s = x[offs+3]; + f0 = pow(s - _s_ref[kk], 2); + } + else { + // + // Alternatively we can formulate an optimization problem with one + // stage (_K == 1) and without final states. This results in 5 + // optimization variables. The initial state value of s is used + // to formulate the criterion for the first measurement point. + // Afterwards the intermediate results for each sample period are used. + // + if (kk == 0) { + s = x[offs+3]; + f0 = pow(s - _s_ref[kk], 2); + s = f[offs+3]; + f0 += pow(s - _s_ref[kk+1], 2); + } + else if (kk < _KK) { + s = f[offs+3]; + f0 = pow(s - _s_ref[kk+1], 2); + } + } +} + +//-------------------------------------------------------------------------- +void Prg_CranePar::continuous(int kk, double t, + const adoublev &x, const adoublev &u, + const adoublev &xp, adoublev &F) +{ + model_eq(kk, t, x, u, F); + for (int i = offs; i < _nx; i++) + F[i] -= xp[i]; +} + +//-------------------------------------------------------------------------- +void Prg_CranePar::model_eq(int kk, double t, + const adoublev &x, const adoublev &u, + adoublev &xp) +{ + // dynamic model variables + adouble den, omega, phi, s, sinphi, u_control, v; + + // redefine the mass parameter and its descendants as adouble + adouble ml, mdl; + + ml = 1000.0 * x[0]; + + // recalculate the bound parameters and implicit discrete part + mdl = md + ml; + + // state assignments + phi = x[offs+0]; + omega = x[offs+1]; + v = x[offs+2]; + s = x[offs+3]; + + // constant control + u_control = -1.0; + + // dynamic model equations + //u_control = u[0]; + sinphi = sin(phi); + den = md + ml*pow(sinphi, 2); + xp[offs+0] = omega; + xp[offs+1] = -(mdl*g*sinphi + 0.5*ml*l*pow(omega, 2)*sin(2*phi) + u_control*Fscale*cos(phi))/(l*den); + xp[offs+2] = (0.5*ml*g*sin(2*phi) + ml*l*pow(omega, 2)*sinphi + u_control*Fscale)/den; + xp[offs+3] = v; +} + +//========================================================================== diff --git a/odc/Prg_CranePar.h b/odc/Prg_CranePar.h new file mode 100644 index 0000000..7ff7dee --- /dev/null +++ b/odc/Prg_CranePar.h @@ -0,0 +1,63 @@ +/* + * Prg_CranePar.h -- + * - parameter/initial states estimation example + * + * rf, 1/15/97 + */ + +#ifndef Prg_CranePar_H +#define Prg_CranePar_H + +#include +#include + +//-------------------------------------------------------------------------- +class Prg_CranePar: public Omu_Program { + + protected: + + VECP _s_ref; + double _maxdev; + int _seed; + bool _multistage; + + void setup_stages(IVECP ks, VECP ts); + + void setup(int k, + Omu_Vector &x, Omu_Vector &u, Omu_Vector &c); + + void update(int kk, + const adoublev &x, const adoublev &u, + adoublev &f, adouble &f0, adoublev &c); + + void continuous(int kk, double t, + const adoublev &x, const adoublev &u, const adoublev &xp, + adoublev &F); + + void model_eq(int kk, double t, + const adoublev &x, const adoublev &u, + adoublev &xp); + + int _nx; // number of states + int offs; // offset for the automatically generated equations + + // model inputs and parameters + double Fscale; + double g; + double l; + double md; + double mdl; + double ml; + + public: + + Prg_CranePar(); + ~Prg_CranePar(); + + int disturb(IF_DEF_ARGS); // method to be called trough Tcl + + char *name() {return "CranePar";} +}; + +#endif + diff --git a/odc/Prg_HS99.C b/odc/Prg_HS99.C new file mode 100644 index 0000000..796e487 --- /dev/null +++ b/odc/Prg_HS99.C @@ -0,0 +1,68 @@ +/* + * Prg_HS99.C -- class definition + * + * rf, 1/13/97 + */ + +#include + +#include + +#include "Prg_HS99.h" + +// propagate the class to the command interface +IF_CLASS_DEFINE("HS99", Prg_HS99, Omu_Program); + +//-------------------------------------------------------------------------- +static double a[] = {0.0, 50.0, 50.0, 75.0, 75.0, 75.0, 100.0, 100.0}; +static double b = 32.0; +static double t[] = {0.0, 25.0, 50.0, 100.0, 150.0, 200.0, 290.0, 380.0}; + +//-------------------------------------------------------------------------- +void Prg_HS99::setup(int k, + Omu_Vector &x, Omu_Vector &u, Omu_Vector &c) +{ + // allocate optimization variables + x.alloc(7); + + // bounds and initial values + for (int i = 0; i < 7; i++) { + x.min[i] = 0.0; + x.max[i] = 1.58; + x.initial[i] = 0.5; + } + + // two equality constraints for final state constraints + c.alloc(2); + c.min[0] = c.max[0] = 1e5; + c.min[1] = c.max[1] = 1e3; +} + +//-------------------------------------------------------------------------- +void Prg_HS99::update(int kk, + const adoublev &x, const adoublev &u, + adoublev &f, adouble &f0, adoublev &c) +{ + adouble r, q, s, p; + + // initial states + r = 0.0; + q = 0.0; + s = 0.0; + + // system integration + for (int i = 1; i < 8; i++) { + r = r + ::a[i] * cos(x[i-1]) * (::t[i] - ::t[i-1]); + p = (::a[i] * sin(x[i-1]) - ::b) * (::t[i] - ::t[i-1]); + q = q + (0.5 * p + s) * (::t[i] - ::t[i-1]); + s = s + p; + } + + f0 = -r*r; + + c[0] = q; + c[1] = s; +} + + +//========================================================================== diff --git a/odc/Prg_HS99.h b/odc/Prg_HS99.h new file mode 100644 index 0000000..5b57f85 --- /dev/null +++ b/odc/Prg_HS99.h @@ -0,0 +1,31 @@ +/* + * Prg_HS99.h -- + * - test example HS99 + * + * rf, 1/13/97 + */ + +#ifndef Prg_HS99_H +#define Prg_HS99_H + +#include + +//-------------------------------------------------------------------------- +class Prg_HS99: public Omu_Program { + + protected: + + void setup(int k, + Omu_Vector &x, Omu_Vector &u, Omu_Vector &c); + + void update(int kk, + const adoublev &x, const adoublev &u, + adoublev &f, adouble &f0, adoublev &c); + + public: + + char *name() {return "HS99";} +}; + +#endif + diff --git a/odc/Prg_HS99omu.C b/odc/Prg_HS99omu.C new file mode 100644 index 0000000..8f72d33 --- /dev/null +++ b/odc/Prg_HS99omu.C @@ -0,0 +1,80 @@ +/* + * Prg_HS99omu.C -- class definition + * + * rf, 1/13/97 + */ + + +#include "Prg_HS99omu.h" + +#include + +// propagate the class to the command interface +IF_CLASS_DEFINE("HS99omu", Prg_HS99omu, Omu_Program); + +//-------------------------------------------------------------------------- +static double a[] = {0.0, 50.0, 50.0, 75.0, 75.0, 75.0, 100.0, 100.0}; +static double b = 32.0; +static double t[] = {0.0, 25.0, 50.0, 100.0, 150.0, 200.0, 290.0, 380.0}; + +//-------------------------------------------------------------------------- +void Prg_HS99omu::setup_stages(IVECP ks, VECP ts) +{ + // allocate seven stages with one sample period per stage + stages_alloc(ks, ts, 7, 1); + + // initialize communication time points + for (int i = 0; i <= _KK; i++) { + ts[i] = ::t[i]; + } +} + +//-------------------------------------------------------------------------- +void Prg_HS99omu::setup(int k, + Omu_Vector &x, Omu_Vector &u, Omu_Vector &c) +{ + x.alloc(3); + if (k < _K) + u.alloc(1); + + // bounds on variables and initial values + if (k < _K) { + u.min[0] = 0.0; + u.max[0] = 1.58; + u.initial[0] = 0.5; + } + + // initial and final state constraints + if (k == 0) { + for (int i = 0; i < 3; i++) + x.min[i] = x.max[i] = 0.0; + } + else if (k == _K) { + x.min[1] = x.max[1] = 1e5; // q(t_K) + x.min[2] = x.max[2] = 1e3; // s(t_K) + } +} + +//-------------------------------------------------------------------------- +void Prg_HS99omu::update(int kk, + const adoublev &x, const adoublev &u, + adoublev &f, adouble &f0, adoublev &c) +{ + if (kk == _KK) { + f0 = -x[0]*x[0]; // -r(t_K)^2 + } +} + +//-------------------------------------------------------------------------- +void Prg_HS99omu::continuous(int kk, double t, + const adoublev &x, const adoublev &u, + const adoublev &xp, adoublev &F) +{ + F[0] = ::a[kk+1] * cos(u[0]); + F[1] = x[2]; // s(t) + F[2] = ::a[kk+1] * sin(u[0]) - ::b; + + F -= xp; +} + +//========================================================================== diff --git a/odc/Prg_HS99omu.h b/odc/Prg_HS99omu.h new file mode 100644 index 0000000..ee3ac51 --- /dev/null +++ b/odc/Prg_HS99omu.h @@ -0,0 +1,37 @@ +/* + * Prg_HS99omu.h -- + * - test example HS99 exploiting Omuses + * + * rf, 1/13/97 + */ + +#ifndef Prg_HS99omu_H +#define Prg_HS99omu_H + +#include + +//-------------------------------------------------------------------------- +class Prg_HS99omu: public Omu_Program { + + protected: + + void setup_stages(IVECP ks, VECP ts); + + void setup(int k, + Omu_Vector &x, Omu_Vector &u, Omu_Vector &c); + + void update(int kk, + const adoublev &x, const adoublev &u, + adoublev &f, adouble &f0, adoublev &c); + + void continuous(int kk, double t, + const adoublev &x, const adoublev &u, + const adoublev &xp, adoublev &F); + + public: + + char *name() {return "HS99omu";} +}; + +#endif + diff --git a/odc/Prg_Maratos.C b/odc/Prg_Maratos.C new file mode 100644 index 0000000..0b6cda6 --- /dev/null +++ b/odc/Prg_Maratos.C @@ -0,0 +1,40 @@ +/* + * Prg_Maratos.C -- class definition + * + * rf, 1/12/97 + */ + +#include + +#include "Prg_Maratos.h" + +IF_CLASS_DEFINE("Maratos", Prg_Maratos, Omu_Program); + +//-------------------------------------------------------------------------- +void Prg_Maratos::setup(int k, + Omu_Vector &x, Omu_Vector &u, Omu_Vector &c) + +{ + x.alloc(2); + x.initial[0] = 0.8; + x.initial[1] = 0.6; + + c.alloc(1); + c.min[0] = c.max[0] = 0.0; +} + +//-------------------------------------------------------------------------- +void Prg_Maratos::update(int kk, + const adoublev &x, const adoublev &u, + adoublev &f, adouble &f0, adoublev &c) +{ + adouble x1, x2; + + x1 = x[0]; + x2 = x[1]; + f0 = -x1 + 10.0*(x1*x1 + x2*x2 - 1.0); + c[0] = x1*x1 + x2*x2 - 1.0; +} + + +//========================================================================== diff --git a/odc/Prg_Maratos.h b/odc/Prg_Maratos.h new file mode 100644 index 0000000..4efbc8f --- /dev/null +++ b/odc/Prg_Maratos.h @@ -0,0 +1,31 @@ +/* + * Prg_Maratos.h -- + * - Maratos problem + * + * rf, 1/12/97 + */ + +#ifndef Prg_Maratos_H +#define Prg_Maratos_H + +#include + +//-------------------------------------------------------------------------- +class Prg_Maratos: public Omu_Program { + + protected: + + void setup(int k, + Omu_Vector &x, Omu_Vector &u, Omu_Vector &c); + + void update(int kk, + const adoublev &x, const adoublev &u, + adoublev &f, adouble &f0, adoublev &c); + + public: + + char *name() {return "Maratos";} +}; + +#endif + diff --git a/odc/Prg_TP383.C b/odc/Prg_TP383.C new file mode 100644 index 0000000..f5fee92 --- /dev/null +++ b/odc/Prg_TP383.C @@ -0,0 +1,60 @@ +/* + * Prg_TP383.C -- class definition + * + * rf, 1/13/97 + */ + +#include "Prg_TP383.h" + +#include + +// propagate the class to the command interface +IF_CLASS_DEFINE("TP383", Prg_TP383, Omu_Program); + +//-------------------------------------------------------------------------- +static double a[] = { + 12842.275, 634.25, 634.25, 634.125, 1268.0, 633.875, 633.75, + 1267.0, 760.05, 633.25, 1266.25, 632.875, 394.46, 940.838 +}; +static double c[] = { + 5.47934, 0.83234, 0.94749, 1.11082, 2.64824, 1.55868, 1.73215, + 3.90896, 2.74284, 2.60541, 5.96184, 3.29522, 1.83517, 2.81372 +}; + +//-------------------------------------------------------------------------- +void Prg_TP383::setup(int k, + Omu_Vector &x, Omu_Vector &u, Omu_Vector &cns) +{ + // allocate optimization variables + x.alloc(14); + + // bounds on variables and initial values + for (int i = 0; i < 5; i++) { + x.min[i] = 0.0; + x.max[i] = 0.04; + x.initial[i] = 0.01; + } + for (int i = 5; i < 14; i++) { + x.min[i] = 0.0; + x.max[i] = 0.03; + x.initial[i] = 0.01; + } + + // one equality constraint + cns.alloc(1); + cns.min[0] = cns.max[0] = 1.0; +} + +//-------------------------------------------------------------------------- +void Prg_TP383::update(int kk, + const adoublev &x, const adoublev &u, + adoublev &f, adouble &f0, adoublev &cns) +{ + for (int i = 0; i < 14; i++) { + f0 += ::a[i] / x[i]; + cns[0] += ::c[i] * x[i]; + } +} + + +//========================================================================== diff --git a/odc/Prg_TP383.h b/odc/Prg_TP383.h new file mode 100644 index 0000000..b2f03b1 --- /dev/null +++ b/odc/Prg_TP383.h @@ -0,0 +1,31 @@ +/* + * Prg_TP383.h -- + * - test example TP383 + * + * rf, 1/13/97 + */ + +#ifndef Prg_TP383_H +#define Prg_TP383_H + +#include + +//-------------------------------------------------------------------------- +class Prg_TP383: public Omu_Program { + + protected: + + void setup(int k, + Omu_Vector &x, Omu_Vector &u, Omu_Vector &c); + + void update(int kk, + const adoublev &x, const adoublev &u, + adoublev &f, adouble &f0, adoublev &c); + + public: + + char *name() {return "TP383";} +}; + +#endif + diff --git a/odc/Prg_TP383omu.C b/odc/Prg_TP383omu.C new file mode 100644 index 0000000..f8868d1 --- /dev/null +++ b/odc/Prg_TP383omu.C @@ -0,0 +1,74 @@ +/* + * Prg_TP383omu.C -- class definition + * + * rf, 1/13/97 + */ + +#include "Prg_TP383omu.h" + +#include + +// propagate the class to the command interface +IF_CLASS_DEFINE("TP383omu", Prg_TP383omu, Omu_Program); + +//-------------------------------------------------------------------------- +static double a[] = { + 12842.275, 634.25, 634.25, 634.125, 1268.0, 633.875, 633.75, + 1267.0, 760.05, 633.25, 1266.25, 632.875, 394.46, 940.838 +}; +static double c[] = { + 5.47934, 0.83234, 0.94749, 1.11082, 2.64824, 1.55868, 1.73215, + 3.90896, 2.74284, 2.60541, 5.96184, 3.29522, 1.83517, 2.81372 +}; + +//-------------------------------------------------------------------------- +void Prg_TP383omu::setup_stages(IVECP ks, VECP ts) +{ + // setup a problem with 14 stages and one sample period per stage + // stages_alloc() initializes ks and ts and sets _K = _KK = 14 + stages_alloc(ks, ts, 14, 1); +} + +//-------------------------------------------------------------------------- +void Prg_TP383omu::setup(int k, + Omu_Vector &x, Omu_Vector &u, Omu_Vector &) +{ + x.alloc(1); + if (k < _K) + u.alloc(1); + + // bounds on variables and initial values + if (k < 5) { + u.min[0] = 0.0; + u.max[0] = 0.04; + u.initial[0] = 0.01; + } + else if (k < _K) { + u.min[0] = 0.0; + u.max[0] = 0.03; + u.initial[0] = 0.01; + } + + // initial and final state constraints + if (k == 0) { + x.min[0] = x.max[0] = 0.0; // s^0 + x.initial[0] = 0.0; + } + else if (k == _K) { + x.min[0] = x.max[0] = 1.0; // s^K + } +} + +//-------------------------------------------------------------------------- +void Prg_TP383omu::update(int kk, + const adoublev &x, const adoublev &u, + adoublev &f, adouble &f0, adoublev &) +{ + if (kk < _KK) { + f0 = ::a[kk] / u[0]; + f[0] = x[0] + ::c[kk] * u[0]; + } +} + + +//========================================================================== diff --git a/odc/Prg_TP383omu.h b/odc/Prg_TP383omu.h new file mode 100644 index 0000000..9a08002 --- /dev/null +++ b/odc/Prg_TP383omu.h @@ -0,0 +1,33 @@ +/* + * Prg_TP383omu.h -- + * - test example TP383, multistage formulation + * + * rf, 1/13/97 + */ + +#ifndef Prg_TP383omu_H +#define Prg_TP383omu_H + +#include + +//-------------------------------------------------------------------------- +class Prg_TP383omu: public Omu_Program { + + protected: + + void setup_stages(IVECP ks, VECP ts); + + void setup(int k, + Omu_Vector &x, Omu_Vector &u, Omu_Vector &c); + + void update(int kk, + const adoublev &x, const adoublev &u, + adoublev &f, adouble &f0, adoublev &c); + + public: + + char *name() {return "TP383omu";} +}; + +#endif + diff --git a/odc/control.ocl b/odc/control.ocl new file mode 100644 index 0000000..09ad64f --- /dev/null +++ b/odc/control.ocl @@ -0,0 +1,38 @@ + +begin + Crane::Crane model; + Simulator sim(model); + sim.display(0, 511); + + ReadFile indata(model); + indata.name := "control.plt"; + indata.read(u.control, "x5"); + + Plotter control(model); + control.display(0, 290); + control.xrange(0, 15.0); + control.yrange(-6.0, 6.0); + control.y(u); + + Plotter position(model); + position.display(270, 290); + position.xrange(0, 15.0); + position.yrange(-1.0, 26.0); + position.y(s); + + Plotter angle(model); + angle.display(540, 290); + angle.xrange(0.0, 15.0); + angle.yrange(-0.2, 0.2); + angle.y(phi); + + % initial states + model.phi := 0.0; % [rad] + model.omega := 0.0; % [rad/s] + model.v := 0.0; % [m/s] + model.s := 25.0; % [m] + + sim.stoptime := 11.6751; % K=50 +% sim.stoptime := 11.6523; % K=250 + +end; diff --git a/odc/crane.c b/odc/crane.c new file mode 100644 index 0000000..c6f35da --- /dev/null +++ b/odc/crane.c @@ -0,0 +1,56 @@ + // bound parameters and implicit discrete part + mdl = md + ml; + + // dynamic model equations + u_control = u[0]; + sinphi = sin(phi); + den = md + ml*pow(sinphi, 2); + xp[offs+0] = omega; + xp[offs+1] = -(mdl*g*sinphi + 0.5*ml*l*pow(omega, 2)*sin(2*phi) + u_control*Fscale*cos(phi))/(l*den); + xp[offs+2] = (0.5*ml*g*sin(2*phi) + ml*l*pow(omega, 2)*sinphi + u_control*Fscale)/den; + xp[offs+3] = v; + + // state assignments + phi = x[offs+0]; + omega = x[offs+1]; + v = x[offs+2]; + s = x[offs+3]; + + // initial state constraints + x.min[offs+0] = x.max[offs+0] = 0.0; // phi + x.min[offs+1] = x.max[offs+1] = 0.0; // omega + x.min[offs+2] = x.max[offs+2] = 0.0; // v + x.min[offs+3] = x.max[offs+3] = 25.0; // s + + // initial states + x.initial[offs+0] = 0.0; // phi + x.initial[offs+1] = 0.0; // omega + x.initial[offs+2] = 0.0; // v + x.initial[offs+3] = 25.0; // s + + // default values for parameters + Fscale = 1000.0; + g = 9.81; + l = 10.0; + md = 1000.0; + ml = 4000.0; + + // interface elements for unbound variables + _ifList.append(new If_Float("prg_Fscale", &Fscale)); + _ifList.append(new If_Float("prg_g", &g)); + _ifList.append(new If_Float("prg_l", &l)); + _ifList.append(new If_Float("prg_md", &md)); + _ifList.append(new If_Float("prg_ml", &ml)); + + // model inputs and parameters + double Fscale; + double g; + double l; + double md; + double mdl; + double ml; + + // dynamic model variables + adouble den, omega, phi, s, sinphi, u_control, v; + + # interface elements for unresolved variables diff --git a/odc/crane.fla b/odc/crane.fla new file mode 100644 index 0000000..a68788a --- /dev/null +++ b/odc/crane.fla @@ -0,0 +1,71 @@ + + + +OmSim Version 3.6a (1996-07-19) started Tue Jan 21 10:00:35 1997 +Copyright (c), Dept. of Automatic Control, 1991 - 1996. All Rights Reserved. + +Dept. of Automatic Control +Lund Institute of Technology +Box 118 +S-221 00 Lund, SWEDEN + +OCL execution started +1234567Instantiating... 1234567ADI Done! +OCL execution finished. +% OmSim Version 3.6a (1996-07-19) +% File generated Tue Jan 21 10:00:41 1997 + +model Crane; + +declare: + +% Parameters: +mdl.default := 5000.0; +Fscale.default := 1000.0; +ml.default := 4000.0; +md.default := 1000.0; +g.default := 9.81; +l.default := 10.0; + +% Continuous State Variables: +s.initial := 25.0; +v.initial := 0.0; +phi.initial := 0.0; +omega.initial := 0.0; + +discrete: + +% No constrained or bound parameters: +%======================================================== + +% Implicit Discrete Part: + +mdl := md + ml; + +%-------------------------------------------------------- + +dynamic: +u.control := *continuousinput*(-1.0, 3986696, 1, time()); + +sinphi := sin(phi); + +den := md + ml*sinphi^2; + +phi' := omega; + +omega' := -(mdl*g*sinphi + 0.5*ml*l*omega^2*sin(2*phi) + u.control*Fscale*cos(phi))/(l*den); + +v' := (0.5*ml*g*sin(2*phi) + ml*l*omega^2*sinphi + u.control*Fscale)/den; + +s' := v; + +%-------------------------------------------------------- + +output: + +u.control.svalue := u.control; + +u := u.control; + +%======================================================== + diff --git a/odc/crane.om b/odc/crane.om new file mode 100644 index 0000000..60f8cf0 --- /dev/null +++ b/odc/crane.om @@ -0,0 +1,78 @@ +% +% Omola model for a container crane +% +% rf, 1/10/97 +% + +library Crane; + +% +% state space model of a container crane +% + +Crane isa Model with + u isa ControlInput with control.default := -1.0; end; + + Fscale isa Parameter with default := 1000.0; end; % [N] + ml isa Parameter with default := 4000.0; end; % [kg] + md isa Parameter with default := 1000.0; end; % [kg] + g isa Parameter with default := 9.81; end; % [m/s2] + l isa Parameter with default := 10.0; end; % [m] + + s, v, phi, omega isa Variable; + + mdl, sinphi, den type real; + + mdl = md + ml; + sinphi = sin(phi); + den = md + ml * sinphi^2; + + s' = v; + v' = (0.5 * ml * g * sin(2*phi) + + ml * l * omega^2 * sinphi + + u * Fscale) / den; + phi' = omega; + omega' = (-mdl * g * sinphi + - 0.5 * ml * l * omega^2 * sin(2*phi) + - u * Fscale * cos(phi)) / (l * den); +end; + +% +% input definitions +% - ControlInput and MeasureInput are SimpleTerminals +% - easy change between several input types possible +% - treatment by fla2c +% + +PolynomInput isa ContinuousInput with + svalue type real; + scale type real := 1.0; + offset type real := 0.0; + svalue := scale * value + offset; +end; + +SampledInput isa ContinuousInput with + svalue type discrete real; + rate type real := 0.1; + scale type real := 1.0; + offset type real := 0.0; + init, sample isan event; + onevent init or sample do + new(svalue) := scale * value + offset; + schedule(sample, rate); + end; +end; + +%InputType isa SampledInput; % piecewise constant inputs +InputType isa PolynomInput; % continuous, piecewise linear inputs + +ControlInput isa SimpleTerminal with + control isa InputType; + value := control.svalue; +end; + +MeasureInput isa SimpleTerminal with + input isa InputType; + value := input.svalue; +end; + diff --git a/odc/crane.tcl b/odc/crane.tcl new file mode 100644 index 0000000..3d80a01 --- /dev/null +++ b/odc/crane.tcl @@ -0,0 +1,63 @@ +# +# Crane optimal control problem +# (graphical output with BLT 2) +# +# rf, 1/16/97 +# + +source omu.tcl + +if {[catch {set tk_version}] + || [catch {load libBLT.so.2}]} { + set plots 0 + puts stderr "Crane plots disabled" +} else { + set plots 1 +} + +proc plot_vars {} { + set tscale [lindex [prg_x] 0] + omu_plot .u0 5 $tscale; omu_plot_titles .u0 {u [kN]} {time [s]} + omu_plot .x1 1 $tscale; omu_plot_titles .x1 {phi [rad]} {time [s]} + omu_plot .x2 2 $tscale; omu_plot_titles .x2 {omega [rad/s]} {time [s]} + omu_plot .x3 3 $tscale; omu_plot_titles .x3 {v [m/s]} {time [s]} + omu_plot .x4 4 $tscale; omu_plot_titles .x4 {s [m]} {time [s]} + update +} + +prg_name Crane + +## apply the bounds to the initial solution in each stage +#prg_bound_init 1 + +prg_tf_guess 10.0 +#prg_tf_guess 15.0 + +prg_K 50 +#prg_K 10 +#prg_K 250 + +prg_setup +prg_simulate + +if $plots plot_vars + +## configure and run the solver +qp_mat_solver LQDOCP + +sqp_init +catch hqp_solve result +puts "Result: $result" + +if $plots plot_vars + +if {$result == "optimal"} { + set tscale [lindex [prg_x] 0] + omu_write_plt control.plt $tscale +} + +if 0 { +omu_plot_dump .u0 crane_u.eps +omu_plot_dump .x1 crane_phi.eps +omu_plot_dump .x4 crane_s.eps +} diff --git a/odc/cranepar.tcl b/odc/cranepar.tcl new file mode 100644 index 0000000..ec9d618 --- /dev/null +++ b/odc/cranepar.tcl @@ -0,0 +1,55 @@ +# +# Crane parameter and initial states estimation +# +# rf, 1/16/97 +# + +source omu.tcl + +proc hqp_exit {reason} { + puts [prg_x] + exit 0 +} + +prg_name CranePar + +## uncomment to change to single stage +#prg_multistage 0 + +## uncomment to switch off automatic differentiation +#prg_ad 0 + +## read the data file and setup the stages +omu_read_plt record.plt +prg_KK [expr {[llength $data(Base::Time)] - 1}] +prg_setup_stages + +## initialize the measurement data and the sample time points for the +## position trajectory [m]; max. deviation to add (+/-) [m]; seed value +prg_ts $data(Base::Time) +prg_s_ref $data(Crane.s.value) +prg_maxdev 0.05 +prg_seed 1234 +prg_disturb + +## optimizer stopping limit +sqp_eps 1e-7 + +## run the optimizer +prg_setup +prg_simulate +sqp_init +catch hqp_solve result + +## print the results +puts "Result: $result" +puts "Obj-evals: [prg_fbd_evals]" +if {$result == "optimal"} { + set x [prg_x] + puts "Estimated mass: [expr 1e3*[lindex $x 0]]" + puts "Initial states: [lrange $x 1 4]" +} else { + hqp_exit $result +} + +exit diff --git a/odc/fla2c/Makefile b/odc/fla2c/Makefile new file mode 100644 index 0000000..f3ed9e3 --- /dev/null +++ b/odc/fla2c/Makefile @@ -0,0 +1,13 @@ + +CC = gcc + +LEXSRC = fla2c.l +PROGRAM = fla2c + +all: lex.yy.o + $(CC) -o $(PROGRAM) lex.yy.o -ll + +lex.yy.o: lex.yy.c + +lex.yy.c: $(LEXSRC) + flex $(LEXSRC) diff --git a/odc/fla2c/fla2c.l b/odc/fla2c/fla2c.l new file mode 100644 index 0000000..8df225e --- /dev/null +++ b/odc/fla2c/fla2c.l @@ -0,0 +1,609 @@ +%{ +/* + * prototye for preparing a Flamola model for Omuses + * + * use OmSim 'Flat model' as input stream + * rf, 6/28/95 + * + * output C code also for system equations + * rf, 4/21/96 + * + * convert {variable}^{number} to pow(...) + * rf, 5/13/96 + * + * rf, 11/4/96 + * -- treatment of conditional expressions + * -- functions must not have spaces between fname and "(" + * as this is now reserved for conditional expressions + * + * rf, 1/18/97 + * -- offset to consider discrete states + * -- index kk instead of k for external inputs + * + * rf, 1/18/97 + * -- new syntax of Omuses 1.2 + * + * rf, 8/24/98 + * -- bugfix (indentifiers may contain underscores) + * + / + +#include +#include +#include +#include + +#ifndef NULL +#define NULL 0 +#endif + +/* declare symbol table */ +typedef enum { + FUNCTION, + VARIABLE, + GLOBAL, + INPUT, + NUMBER +} SymType; + +typedef enum { + STATE = 1, /* dynamic state variable */ + CONTROL = 2, /* control input */ + TEMPORAL = 4, /* intermediate variable of dynamic part */ + RESOLVED = 8, /* varariable is defined by an equation */ + USED = 16 /* variable is used in other equations */ +} SymAttr; + +typedef struct SymEntry { + char *name; + char *value; + int number; + SymType type; + SymAttr attr; + struct SymEntry *next; + struct SymEntry *prev; +} SymEntry; + +static void mname_store(char *name); +static void symexp_store(char *name); +static SymEntry *symlook(char *name, SymType type, SymAttr attr); +static SymEntry *symentry; + +static void print_maple_defs(); + +%} + +blanc [ \t] +digit [0-9] +letter [A-Za-z_] +id {letter}({letter}|{digit})* +variable {id}(\.{id})* +expansion "{"{variable}"}"|"{}" +global {id}"::"{id} +number ({digit}+|({digit}*\.{digit}+))([Ee][+-]?{digit}+)? +input "*continuousinput*"\([^)]*"time()"\) + +/* + * states: + * INITIAL Lex's initial state + * Snapshot + * DECLARE default and initial values for parameters variables, resp. + * Parameter part, implicit discrete part + * DISCRETE + * Continuous manipulated + * DYNAMIC dynamic part + */ + +%s DECLARE +%s DISCRETE +%s DYNAMIC +%% + + +"%" { + while (input() != '\n'); /* eat up comments */ +} + +"model "{id} { + mname_store(yytext+6); + input(); /* following semicolon */ +} + +"declare:"|"% Parameters:"|"% Continuous State Variables:" { + BEGIN(DECLARE); +} +{variable}/".default" { + symentry = symlook(yytext, VARIABLE, 0); +} +{variable}/".initial" { + symentry = symlook(yytext, VARIABLE, 0); +} +{number} { + if (symentry) { + symentry->value = (char *)malloc(strlen(yytext) + 1); + strcpy(symentry->value, yytext); + } +} + +"discrete:" { + printf(" // bound parameters and implicit discrete part\n"); + BEGIN(DISCRETE); +} +{variable}/{blanc}*:= { + printf(" %s", symlook(yytext, VARIABLE, RESOLVED)->name); +} +{variable}{blanc}*"^"{blanc}*{number} { + int i; + for (i = 0; yytext[i] != '^'; i++); + yytext[i] = '\0'; + printf("pow(%s, %s)", symlook(yytext, VARIABLE, RESOLVED)->name, + yytext + i + 1); + yytext[i] = '^'; +} +{variable} { + printf("%s", symlook(yytext, VARIABLE, USED)->name); +} +{global} { + printf("%s", symlook(yytext, GLOBAL, USED)->name); +} +{id}/"(" { + printf("%s", symlook(yytext, FUNCTION, RESOLVED | USED)->name); +} +:= { + printf("="); +} +";" { + printf(";\n"); +} +. { + printf("%s", yytext); +} + +"dynamic:" { + printf("\n // dynamic model equations\n"); + BEGIN(DYNAMIC); +} +^{variable}/{blanc}*"," { + symlook(yytext, VARIABLE, TEMPORAL); +} +{variable}/"'" { + printf(" xp[offs+%d]", symlook(yytext, VARIABLE, STATE)->number); + input(); /* eat up following quote */ +} +{variable}/{blanc}*:= { + /* backing store symentry for detecting control inputs */ + if (strcmp(yytext + strlen(yytext) - 8, ".control") == 0) + symentry = symlook(yytext, VARIABLE, CONTROL | TEMPORAL); + else + symentry = symlook(yytext, VARIABLE, TEMPORAL); + printf(" %s", symentry->name); +} +{variable} { + if (strcmp(yytext, "then") == 0) + printf("? (adouble)("); + else if (strcmp(yytext, "else") == 0) + printf("): (adouble)"); + else if (strcmp(yytext, "if") != 0) + printf("%s", symlook(yytext, VARIABLE, USED)->name); +} +{global} { + printf("%s", symlook(yytext, GLOBAL, USED)->name); +} +{input} { + if (symentry->attr & CONTROL) { /* last seen symbol was a control */ + symentry = symlook(yytext, INPUT, CONTROL | USED); + printf("u[%d]", symentry->number); + } + else + printf("%s[kk]", symlook(yytext, INPUT, USED)->name); +} +{id}/"(" { + printf("%s", symlook(yytext, FUNCTION, RESOLVED | USED)->name); +} +{number} { + /* introduce symbols, as Maple can't handle float numbers */ +/* printf("%s", symlook(yytext, NUMBER, RESOLVED | USED)->name); */ + printf("%s", symlook(yytext, NUMBER, RESOLVED | USED)->value); +} +:= { + printf("="); +} +";" { + printf(";\n"); +} +. { + printf("%s", yytext); +} +"output:" { + printf("\n"); + BEGIN(INITIAL); +} + +.|\n +%% + +/* bottom of list for symbol table */ +static SymEntry *symbot; + +/* + * -- store symbol expansion in "symexp" + * -- store length of name of a model in "mnamelen" + * -- process current symbol name in "symbol" + * + */ +static char *symexp; +static int symexpsize; /* allocated memory */ +static int symexplen; /* currently stored string */ +static char *mname; +static int mnamelen; +static char *symbol; +static int symbolsize; +static int nnumbers; /* count symbols introduced for numbers */ +static int nstates; /* count symbols introduced for states */ +static int ncontrols; /* count symbols introduced for controls */ + +int main() +{ + SymEntry *entry; + SymEntry **states; + int after_entry; + int i; + + symbot = NULL; + + mname = (char *)0; + mnamelen = 0; + + symexpsize = 1; + symexp = (char *)malloc(symexpsize); + symexp[0] = 0; + + symbolsize = 10; + symbol = (char *)malloc(symbolsize); + + nnumbers = 0; + nstates = 0; + + yylex(); + + /* sort states according to flat model */ + states = (SymEntry **)malloc(nstates * sizeof(SymEntry *)); + entry = symbot; + while (entry != NULL) { + if (entry->attr & STATE) { + states[entry->number] = entry; + } + entry = entry->next; + } + + printf(" // state assignments\n"); + for (i = 0; i < nstates; i++) { + entry = states[i]; + printf(" %s = x[offs+%d];\n", entry->name, entry->number); + } + + printf("\n // initial state constraints\n"); + for (i = 0; i < nstates; i++) { + entry = states[i]; + if (entry->type == VARIABLE && entry->value != NULL) + printf(" x.min[offs+%d] = x.max[offs+%d] = %s;\t// %s\n", + entry->number, entry->number, entry->value, entry->name); + } + + printf("\n // initial states\n"); + for (i = 0; i < nstates; i++) { + entry = states[i]; + if (entry->type == VARIABLE && entry->value != NULL) + printf(" x.initial[offs+%d] = %s;\t// %s\n", + entry->number, entry->value, entry->name); + } + + printf("\n // default values for parameters\n"); + entry = symbot; + while (entry != NULL) { + if (!(entry->attr & (STATE | CONTROL | TEMPORAL | RESOLVED))) { + if (entry->type == VARIABLE && entry->value != NULL) + printf(" %s = %s;\n", entry->name, entry->value); + } + entry = entry->next; + } + + printf("\n // interface elements for unbound variables\n"); + entry = symbot; + while (entry != NULL) { + if (entry->attr == USED) { + switch (entry->type) { + case INPUT: + printf(" _ifList.append(new If_FloatVec(\"prg_%s\", &%s));\n", + entry->name, entry->name); + break; + default: + printf(" _ifList.append(new If_Float(\"prg_%s\", &%s));\n", + entry->name, entry->name); + break; + } + } + entry = entry->next; + } + + printf("\n // model inputs and parameters\n"); + entry = symbot; + while (entry != NULL) { + if (!(entry->attr & (STATE | CONTROL | TEMPORAL)) + && (entry->attr & (USED | RESOLVED))) { + switch (entry->type) { + case VARIABLE: + case GLOBAL: + printf(" double %s;\n", entry->name); + break; + case INPUT: + printf(" VECP %s;\n", entry->name); + break; + default: + break; + } + } + entry = entry->next; + } + + printf("\n // dynamic model variables\n"); + entry = symbot; + after_entry = 0; + while (entry != NULL) { + if (entry->attr & (TEMPORAL | STATE)) { + if (after_entry) + printf(", "); + else + printf(" adouble "); + printf("%s", entry->name); + after_entry = 1; + } + entry = entry->next; + } + printf(";\n"); + + printf("\n # interface elements for unresolved variables\n"); + entry = symbot; + while (entry != NULL) { + if (entry->attr == USED && entry->value == NULL) { + printf(" prg_%s\t\n", entry->name); + } + entry = entry->next; + } + + return 0; +} + + +static void print_maple_defs() +{ + SymEntry *entry; + int after_entry; + + /* define set of float constants */ + printf("floats := {\n"); + entry = symbot; + after_entry = 0; + while (entry != NULL) { + if (entry->type == NUMBER) { + if (after_entry) + printf(",\n"); + printf("%s = %s", entry->name, entry->value); + after_entry = 1; + } + entry = entry->next; + } + printf("\n}:\n"); + + /* define set of temporals */ + printf("temporals := {\n"); + entry = symbot; + after_entry = 0; + while (entry != NULL) { + if (entry->attr & TEMPORAL) { + if (after_entry) + printf(",\n"); + printf("%s", entry->name); + after_entry = 1; + } + entry = entry->next; + } + printf("\n}:\n"); + + /* define set of states */ + printf("states := [\n"); + entry = symbot; + after_entry = 0; + while (entry != NULL) { + if (entry->attr & STATE) { + if (after_entry) + printf(",\n"); + printf("%s", entry->name); + after_entry = 1; + } + entry = entry->next; + } + printf("\n]:\n"); + + /* controls must be added by hand */ + printf("controls := [\n]:\n"); + + printf("\n"); +} + +static void dot2score(char *name) +{ + while (*name != 0) { + if (*name == '.' || *name == ':') + *name = '_'; + name ++; + } +} + +static void mname_store(char *name) +{ + /* + * -- determine mnamelen, including '.' + * -- store model name + */ + + mnamelen = strlen(name) + 1; + mname = (char *)malloc(mnamelen + 1); + strcpy(mname, name); + mname[mnamelen - 1] = '.'; + mname[mnamelen] = 0; +} + +static void symexp_store(char *name) +{ + /* + * -- store expansion for OHM names, add a '.' + */ + + symexplen = strlen(name) - 2 - mnamelen; /* without "{}" */ + if (symexplen < 0) { + symexp[0] = 0; + symexplen = 0; + return; + } + name += 1 + mnamelen; + if (symexplen + 2 > symexpsize) { + symexpsize = symexplen + 2; + symexp = (char *)realloc(symexp, symexpsize); + } + strcpy(symexp, name); + symexp[symexplen++] = '.'; + symexp[symexplen] = 0; +} + +static SymEntry *symlook(char *name, SymType type, SymAttr attr) +{ + SymEntry *entry, *insert; + int maxsize, len; + int input, cmp; + + /* + * -- convert name into a valid symbol + * -- look symbol up in symbol table + * -- add a new entry, if not found + */ + + maxsize = symexplen + strlen(name) + 1; + if (maxsize > symbolsize) { + symbolsize = maxsize; + symbol = (char *)realloc(symbol, symbolsize); + } + + switch (type) { + + case VARIABLE: + /* manage symbol expansion */ + if (symexplen != 0 && strncmp(name, mname, mnamelen) != 0) { + /* add expansion */ + strcpy(symbol, symexp); + strcpy(symbol + symexplen, name); + } + else if (strncmp(name, mname, mnamelen) == 0) { + /* skip model name */ + name += mnamelen; + strcpy(symbol, name); + } + else + strcpy(symbol, name); + break; + + case INPUT: + len = strlen(symentry->name); + if (strcmp(symentry->name + len - 8, "_control") == 0) { + sprintf(symbol, "%s", symentry->name); + symbol[len - 8] = '\0'; + } + else if (strcmp(symentry->name + len - 6, "_input") == 0) { + sprintf(symbol, "%s", symentry->name); + symbol[len - 6] = '\0'; + } + else { + /* convert "*continuousinput*(.., ..., , time())" into "_i" */ + while (*name ++ != ','); + while (*name ++ != ','); + sscanf(name, "%d,", &input); + sprintf(symbol, "_i%d", input); + } + break; + + case NUMBER: + /* convert float constant into _f" */ + entry = symbot; + while (entry != NULL) { + if (entry->type == NUMBER && strcmp(name, entry->value) == 0) { + strcpy(symbol, entry->name); + break; + } + entry = entry->next; + } + if (entry == NULL) { + sprintf(symbol, "_f%d", ++nnumbers); + } + break; + + default: + strcpy(symbol, name); + break; + } + + if (type != NUMBER) + dot2score(symbol); + + entry = symbot; + insert = NULL; + while (entry != NULL) { + cmp = strcmp(symbol, entry->name); + if (cmp == 0 && entry->type == type) { + if (attr & STATE && !(entry->attr & STATE)) { + entry->number = nstates++; + } + entry->attr |= attr; + return entry; + } + if (cmp > 0) + insert = entry; + entry = entry->next; + } + + /* + * allocate and initialize a new entry + */ + entry = (SymEntry *)malloc(sizeof(SymEntry)); + if (insert == NULL) { + /* go on the bottom */ + entry->prev = NULL; + entry->next = symbot; + symbot = entry; + } + else { + /* go behind insert */ + entry->prev = insert; + entry->next = insert->next; + insert->next = entry; + } + entry->name = (char *)malloc(strlen(symbol) + 1); + strcpy(entry->name, symbol); + entry->type = type; + entry->attr = attr; + entry->number = -1; + if (type == NUMBER) { + entry->value = (char *)malloc(strlen(name) + 1); + strcpy(entry->value, name); + } + else + entry->value = NULL; + + if (attr & STATE) { + entry->number = nstates++; + } + else if (type == INPUT && attr & CONTROL) { + entry->number = ncontrols++; + } + + return entry; +} diff --git a/odc/init.ocl b/odc/init.ocl new file mode 100644 index 0000000..60bdcef --- /dev/null +++ b/odc/init.ocl @@ -0,0 +1,21 @@ +% +% Ocl script for initializing a model prior to Flamola output +% +% rf, 1/17/97 +% + +begin + Crane::Crane model; + Simulator sim(model); + sim.display(0, 511); + + % initial states + model.s := 25.0; + model.v := 0.0; + model.phi := 0.0; + model.omega := 0.0; + + % initialize all model variables + sim.step; + sim.step; +end; diff --git a/odc/maratos.tcl b/odc/maratos.tcl new file mode 100644 index 0000000..a6e16b9 --- /dev/null +++ b/odc/maratos.tcl @@ -0,0 +1,19 @@ +# +# demo for Schittkowski's differentiable penalty function +# + +prg_name Maratos + +## toggle comments +#sqp_solver Powell +sqp_solver Schittkowski + +prg_setup +sqp_init +catch hqp_solve result + +puts "Result : $result" +puts "Objective: [prg_f]" +puts "Obj-evals: [prg_fbd_evals]" +puts "Variables: [prg_x]" +exit diff --git a/odc/omu.tcl b/odc/omu.tcl new file mode 100644 index 0000000..869e34a --- /dev/null +++ b/odc/omu.tcl @@ -0,0 +1,191 @@ +# +# some Tcl procedures for Omuses +# +# rf, 1/16/97 +# + +# +# generate a vector of start/end times of all stages +# +proc omu_k_times {} { + + set ts [prg_ts] + set k_times {} + foreach k [prg_ks] { + lappend k_times [lindex $ts $k] + } + return $k_times +} + +# +# read an OmSim-like data file into the global array data +# +proc omu_read_plt {fname {tstart all} {tend all} {dtmin 0.0}} { + global data + + set fp [open $fname r] + + gets $fp line + set ndata [lindex $line 2] + set names {} + for {set i 0} {$i < $ndata} {incr i} { + gets $fp line + lappend names $line + set data($line) {} + set data(zeros) {} + } + set tprev first + set lastpos -1 + while {1} { + gets $fp line + if [eof $fp] break + set time [lindex $line 0] + if {$tstart != "all" && $time < $tstart} continue + if {$tend != "all" && $time > $tend} break + if {$time == $tprev} { + # replace the last point until the time increases + for {set i 0} {$i < $ndata} {incr i} { + set data([lindex $names $i]) \ + [lreplace $data([lindex $names $i]) $lastpos $lastpos \ + [lindex $line $i]] + } + } elseif {$tprev == "first" || $time >= [expr $tprev+$dtmin]} { + # append a new point + for {set i 0} {$i < $ndata} {incr i} { + lappend data([lindex $names $i]) [lindex $line $i] + } + incr lastpos + set tprev $time + } + } + close $fp +} + +# +# write current prg_x into an OmSim-like data file +# (this procedure only works for a constant number of variables per stage!) +# +proc omu_write_plt {fname {tscale 1.0}} { + + set fp [open $fname w] + + set vars [prg_x] + set k_times [omu_k_times] + set kdim [llength $k_times] + set xdim [lindex [prg_nxs] 0] + set udim [lindex [prg_nus] 0] + set sdim [expr $xdim+$udim] + + # write the file header + puts $fp "$kdim 0 [expr $sdim+1]" + puts -nonewline $fp "time" + for {set i 0} {$i < $xdim} {incr i} { + puts -nonewline $fp "\nx$i" + } + for {set i 0} {$i < $udim} {incr i} { + puts -nonewline $fp "\nu$i" + } + + set idx 0 + foreach kt $k_times { + puts -nonewline $fp "\n[expr $tscale*$kt] " + puts -nonewline $fp [lrange $vars $idx [expr $idx+$sdim-1]] + incr idx $sdim + } + + # rewrite the controls of the last stage at the final time + incr idx [expr -$sdim-$udim] + puts $fp " [lrange $vars $idx [expr $idx+$udim-1]]" + + close $fp +} + +# +# plot results into a BLT graph +# (this procedure only works for a constant number of variables per stage!) +# +proc omu_plot {w sidx {tscale 1.0}} { + + if {![winfo exists $w]} { + toplevel $w + wm minsize $w 10 10 + set xtitle time + set ytitle "" + regexp {.*\.([^.]*)} $w all ytitle + graph $w.g \ + -title {} \ + -plotborderwidth 0 \ + -background white \ + -plotbackground white \ + -width 500 \ + -height 200 + $w.g xaxis configure \ + -title $xtitle + $w.g yaxis configure \ + -loose true \ + -title $ytitle + $w.g legend configure \ + -mapped false + + pack $w.g -fill both -expand true + } + + set vars [prg_x] + set k_times [omu_k_times] + set sdim [lindex [prg_nxs] 0] + if {$sidx >= $sdim} { + set control 1 + } else { + set control 0 + } + incr sdim [lindex [prg_nus] 0] + set k 0 + set K [llength $k_times]; incr K -1 + set xdata {} + set ydata {} + set idx $sidx + set dim [llength $vars] + set t [expr $tscale*[lindex $k_times 0]] + while {$idx < $dim} { + set var [lindex $vars $idx] + lappend xdata $t + lappend ydata $var + if {$idx >= $dim} break + incr k + if {$k > $K} break + set t [expr $tscale*[lindex $k_times $k]] + if {$control} { + # piecewise constant + lappend xdata $t + lappend ydata $var + } + incr idx $sdim + } + + set nitems [llength [$w.g element names]] + $w.g element create g$nitems \ + -xdata $xdata \ + -ydata $ydata + + incr nitems -1 + if {$nitems >= 0} { + $w.g element configure g$nitems \ + -color gray + } +} + +proc omu_plot_titles {w ytitle xtitle} { + + $w.g yaxis configure \ + -title $ytitle + $w.g xaxis configure \ + -title $xtitle +} + +proc omu_plot_dump {w fname} { + + update + $w.g postscript config -padx 0 -pady 0 + $w.g postscript output $fname -decorations no +} + diff --git a/odc/record.ocl b/odc/record.ocl new file mode 100644 index 0000000..395240e --- /dev/null +++ b/odc/record.ocl @@ -0,0 +1,35 @@ +begin + Crane::Crane model; + Simulator sim(model); + sim.display(0, 511); + + Plotter control(model); + control.display(0, 290); + control.xrange(0, 15.0); + control.yrange(-6.0, 6.0); + control.y(u); + + Plotter position(model); + position.display(270, 290); + position.xrange(0, 15.0); + position.yrange(-1.0, 26.0); + position.y(s); + + StoreFile outdata(model); + outdata.name := "record.plt"; + outdata.store(s); + + % container mass + model.ml := 6000.0; % [kg] + + % initial states + model.phi := 0.1; % [rad] + model.omega := 0.2; % [rad/s] + model.v := -2.0; % [m/s] + model.s := 20.0; % [m] + + sim.stoptime := 5.0; + sim.outputstep := 5.0; + + sim.start; +end; diff --git a/odc/record.plt b/odc/record.plt new file mode 100644 index 0000000..aa0da07 --- /dev/null +++ b/odc/record.plt @@ -0,0 +1,24 @@ +853841846 0 2 +Base::Time +Crane.s.value +0.0 20.0 +0.25 19.67 +0.5 19.7032 +0.75 20.0624 +1.0 20.5886 +1.25 21.0143 +1.5 21.1177 +1.75 20.8237 +2.0 20.1857 +2.25 19.3995 +2.5 18.7393 +2.75 18.392 +3.0 18.41 +3.25 18.7361 +3.5 19.1792 +3.75 19.4635 +4.0 19.3981 +4.25 18.9363 +4.5 18.1601 +4.75 17.2894 +5.0 16.5949 diff --git a/odc/run b/odc/run new file mode 100755 index 0000000..742a7d5 --- /dev/null +++ b/odc/run @@ -0,0 +1,79 @@ +#!./odc +# +# rf, 2/7/97 +# + +## say Hello + +set version "Omuses [omu_version]" +if [catch { + label .l \ + -text $version + button .b \ + -text Exit \ + -command {hqp_exit user} + pack .l .b + update +}] { + puts $version +} + +## use the first runtime argument as problem name +## run a problem specific script file if provided +## else run without configurations + +set pname [lindex $argv 0] +set fname [string tolower $pname].tcl +if [file exists $fname] { + source $fname +} else { + +if [catch {prg_name $pname} result] { + puts stderr "Usage: run " + puts stderr $result + exit +} + +## configure the problem and the solver + +## use simple RK4 integration for continuous-time equations +#prg_integrator RK4 + +## use RKsuite (default) +#prg_integrator RKsuite +#prg_int_rtol 1e-6 +#prg_int_atol 1e-12 + +## optimization stopping limit +#sqp_eps 1e-6 + +## run the solver + +# setup the problem +prg_setup + +# perform an initial-value simulation +# (this is only needed to initialize additional states variables) +prg_simulate + +# initialize the SQP solver +sqp_init + +# evaluate the Tcl procedure hqp_solve and catch errors +catch hqp_solve result + +## print the results and exit + +puts "Result : $result" +puts "Objective: [prg_f]" +puts "Obj-evals: [prg_fbd_evals]" +set x [prg_x] +set n [llength $x] +if {$n <= 100} { + puts "Variables:" + for {set i 0} {$i < $n} {incr i} { + puts [lrange $x $i [incr i 7]] + } + exit +} +} diff --git a/odc/runall b/odc/runall new file mode 100755 index 0000000..7017a27 --- /dev/null +++ b/odc/runall @@ -0,0 +1,11 @@ +#!/bin/sh +# +# rf, 11/07/00 +# + +for p in TP383 TP383omu HS99 HS99omu Maratos CranePar Crane; do + echo $p: + ./run $p + echo "" +done + diff --git a/omu/F2CMAIN.C b/omu/F2CMAIN.C new file mode 100644 index 0000000..2fe1437 --- /dev/null +++ b/omu/F2CMAIN.C @@ -0,0 +1,33 @@ +/* + * provide a dummy MAIN__ function for g77 that should never be called + * + * rf, 8/16/96 + */ + +/* + Copyright (C) 1997--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +extern "C" void MAIN__() +{ + fprintf(stderr, "MAIN__() called!\n"); + exit(-1); +} diff --git a/omu/Hqp_Docp_stub.C b/omu/Hqp_Docp_stub.C new file mode 100644 index 0000000..7df1bea --- /dev/null +++ b/omu/Hqp_Docp_stub.C @@ -0,0 +1,133 @@ +/* + * Hqp_Docp_stub.C -- class definition + * + * rf, 1/11/00 + */ + +/* + Copyright (C) 1997--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include "Hqp_Docp_stub.h" + +//------------------------------------------------------------------------- +static void setup_horizon(void *clientdata, int &k0, int &kf) +{ + ((Hqp_Docp_stub *)clientdata)->setup_horizon(k0, kf); +} + +//------------------------------------------------------------------------- +static void setup_vars(void *clientdata, int k, + VECP x, VECP xmin, VECP xmax, + VECP u, VECP umin, VECP umax, + VECP c, VECP cmin, VECP cmax) +{ + ((Hqp_Docp_stub *)clientdata)->setup_vars(k, x, xmin, xmax, + u, umin, umax, + c, cmin, cmax); +} + +//------------------------------------------------------------------------- +static void setup_struct(void *clientdata, int k, + VECP f0x, VECP f0u, int &f0_lin, + MATP fx, MATP fu, IVECP f_lin, + MATP cx, MATP cu, IVECP c_lin, + MATP Lxx, MATP Luu, MATP Lxu) +{ + ((Hqp_Docp_stub *)clientdata)->setup_struct(k, + f0x, f0u, f0_lin, + fx, fu, f_lin, + cx, cu, c_lin, + Lxx, Luu, Lxu); +} + +//------------------------------------------------------------------------- +static void init_simulation(void *clientdata, int k, + VECP x, VECP u) +{ + ((Hqp_Docp_stub *)clientdata)->init_simulation(k, x, u); +} + +//------------------------------------------------------------------------- +static void update_vals(void *clientdata, int k, + const VECP x, const VECP u, + VECP f, Real &f0, VECP c) +{ + ((Hqp_Docp_stub *)clientdata)->update_vals(k, x, u, f, f0, c); +} + +//------------------------------------------------------------------------- +static void update_stage(void *clientdata, int k, + const VECP x, const VECP u, + VECP f, Real &f0, VECP c, + MATP fx, MATP fu, + VECP f0x, VECP f0u, + MATP cx, MATP cu, + const VECP rf, const VECP rc, + MATP Lxx, MATP Luu, MATP Lxu) +{ + ((Hqp_Docp_stub *)clientdata)->update_stage(k, x, u, f, f0, c, + fx, fu, f0x, f0u, cx, cu, + rf, rc, Lxx, Luu, Lxu); +} + +//------------------------------------------------------------------------- +Hqp_Docp_stub::Hqp_Docp_stub() +{ + _k0 = 0; + _kf = 0; + + Hqp_Docp_spec spec; + spec.setup_horizon = ::setup_horizon; + spec.setup_vars = ::setup_vars; + spec.setup_struct = ::setup_struct; + spec.init_simulation = ::init_simulation; + spec.update_vals = ::update_vals; + spec.update_stage = ::update_stage; + + _handle = Hqp_Docp_create(spec, this); +} + +//------------------------------------------------------------------------- +Hqp_Docp_stub::~Hqp_Docp_stub() +{ + Hqp_Docp_destroy(_handle); +} + +//------------------------------------------------------------------------- +void Hqp_Docp_stub::horizon(int k0, int kf) +{ + _k0 = k0; + _kf = kf; +} + +//------------------------------------------------------------------------- +void Hqp_Docp_stub::setup_horizon(int &k0, int &kf) +{ + k0 = _k0; + kf = _kf; +} + +//------------------------------------------------------------------------- +void Hqp_Docp_stub::alloc_vars(VECP v, VECP vmin, VECP vmax, int n) +{ + Hqp_Docp_alloc_vars(_handle, v, vmin, vmax, n); +} + + +//========================================================================= diff --git a/omu/Hqp_Docp_stub.h b/omu/Hqp_Docp_stub.h new file mode 100644 index 0000000..4faad3b --- /dev/null +++ b/omu/Hqp_Docp_stub.h @@ -0,0 +1,88 @@ +/* + * Hqp_Docp_stub.h -- + * Client stub for Hqp_Docp interface + * + * rf, 10/31/00 + * + */ + +/* + Copyright (C) 1997--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_Docp_stub_H +#define Hqp_Docp_stub_H + +#include + +//------------------- +class Hqp_Docp_stub { + +private: + Hqp_Docp_handle _handle; + int _k0, _kf; // store back arguments of horizon(int, int) + +public: + + Hqp_Docp_stub(); + virtual ~Hqp_Docp_stub(); + + // methods that may be called by implementation + //--------------------------------------------- + void horizon(int k0, int kf); + + // methods that are provided by implementation + //-------------------------------------------- + virtual void setup_horizon(int &k0, int &kf); + + virtual void setup_vars(int k, + VECP x, VECP xmin, VECP xmax, + VECP u, VECP umin, VECP umax, + VECP c, VECP cmin, VECP cmax) = 0; + + virtual void setup_struct(int k, + VECP f0x, VECP f0u, int &f0_lin, + MATP fx, MATP fu, IVECP f_lin, + MATP cx, MATP cu, IVECP c_lin, + MATP Lxx, MATP Luu, MATP Lxu) {} + + virtual void init_simulation(int k, VECP x, VECP u) {} + + virtual void update_vals(int k, const VECP x, const VECP u, + VECP f, Real &f0, VECP c) = 0; + + virtual void update_stage(int k, const VECP x, const VECP u, + VECP f, Real &f0, VECP c, + MATP fx, MATP fu, VECP f0x, VECP f0u, + MATP cx, MATP cu, + const VECP rf, const VECP rc, + MATP Lxx, MATP Luu, MATP Lxu) + { + // call default implementation provided by Hqp_Docp + Hqp_Docp_update_stage(_handle, k, x, u, f, f0, c, + fx, fu, f0x, f0u, cx, cu, + rf, rc, Lxx, Luu, Lxu); + } + + // utility routines that may be called by implementation + //------------------------------------------------------ + void alloc_vars(VECP v, VECP vmin, VECP vmax, int n); +}; + + +#endif diff --git a/omu/Hqp_Omuses.C b/omu/Hqp_Omuses.C new file mode 100644 index 0000000..8e7a302 --- /dev/null +++ b/omu/Hqp_Omuses.C @@ -0,0 +1,788 @@ +/* + * Hqp_Omuses.C -- + * -- class implementation + * + * rf, 7/27/96 + * + * rf, 1/25/97 + * -- discrete states are by default constant + * -- continuous states may be remapped in discrete() + * + * rf, 1/29/98 + * -- bug fix in obtain_structure (as detected by H. Linke) + */ + +/* + Copyright (C) 1997--2001 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include "Hqp_Omuses.h" + +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "Omu_Vars.h" +#include "Omu_Program.h" +#include "Omu_Integrator.h" + +#include "Omu_IntDopri5.h" + +typedef If_Method If_Cmd; + +//-------------------------------------------------------------------------- +static short** myalloc_short(int m, int n) +{ + short* Adum = (short*)malloc(m*n*sizeof(short)); + short** A = (short**)malloc(m*sizeof(short*)); + int i; + for(i=0;i _max_ndep + || nindep > _max_nindep + || npar > _max_npar) { + ad_free(); + ad_alloc(ndep, nindep, npar); + } +} + +//-------------------------------------------------------------------------- +int Hqp_Omuses::setup_stages(IF_CMD_ARGS) +{ + assert(_prg != NULL); + + int K; + + _prg->setup_stages(); + + K = _prg->ks()->dim - 1; + + delete [] _cs; + delete [] _us; + delete [] _xs; + _xs = new Omu_States [K+1]; + _us = new Omu_Vars [K+1]; + _cs = new Omu_Vars [K+1]; + + _stages_ok = true; + + return IF_OK; +} + +//-------------------------------------------------------------------------- +void Hqp_Omuses::setup_horizon(int &k0, int &kf) +{ + assert(_prg != NULL); + + // call setup_stages if this wasn't already done through the interface + if (!_stages_ok) + setup_stages(); + + _stages_ok = false; // for subsequent problem modifications + + // + // setup the optimization horizon and related data + // + + k0 = 0; + kf = _prg->ks()->dim - 1; +} + +//-------------------------------------------------------------------------- +void Hqp_Omuses::obtain_structure(int k, + Omu_States &xk, const Omu_Vector &uk) +{ + if (!_prg) { + error(E_NULL, "Hqp_Omuses::obtain_structure"); + } + + // + // determine the number of discrete-time states per sample period + // + + int i, j, nd, kk, sbw; + int nxt = xk->dim; + int nx = nxt - xk.nv; + int nu = uk->dim; + int nxtu = nxt + nu; + int K = _prg->ks()->dim - 1; + + if (k == K) { + xk.nd = nxt; + v_zero(xk.D); + return; + } + + adoublev ax(nxt); + adoublev au(nu); + adoublev axp(nxt); + adoublev aF(nxt); + int ndep, nindep; + int depends, sumdepends; + double dummy; + + ndep = nxt; + nindep = 2*nxt + nu; + ad_realloc(ndep, nindep, nx+nu); + + kk = _prg->ks(k); + v_resize(_xt, nxt); + _prg->consistic(kk, _prg->ts(kk), xk, uk, _xt); + + // record a residuum evaluation + + trace_on(2, 1); // tape 2, keep = 1 for following reverse call + ax <<= _xt->ve; + au <<= uk->ve; + for (i = 0; i < nxt; i++) + axp[i] <<= 0.0; + + _prg->continuous(kk, _prg->ts(kk), ax, au, axp, aF); + + for (i = 0; i < nxt; i++) + aF[i] >>= dummy; + + trace_off(); + + // obtain nonzero pattern + + reverse(2, ndep, nindep, 0, _Z3, _nz); + + nd = 0; + sumdepends = 0; + xk.D_is_const = true; + for (i = 0; i < nxt; i++) { + depends = 0; + for (j = 0; j < nxtu; j++) { + sumdepends += _nz[i][j]; + } + for (j = nxtu; j < nindep; j++) { + sumdepends += _nz[i][j]; + depends += _nz[i][j]; + } + if (sumdepends == 0) { + xk.flags[i] |= Omu_States::Discrete; + xk.D[nd] = 0.0; + nd++; + } + if (depends > 1 || _nz[i][nxtu + i] - depends != 0) { + xk.D_is_const = false; + } + xk.D[i] = _Z3[i][nxtu + i][0]; + + } + xk.nd = nd; + + // obtain structure of continuous equations + xk.na = 0; + for (i = nd; i < nxt; i++) { + // check for algebraic states in column i of dF/dxp + depends = 0; + for (j = nd; j < nxt; j++) { + depends += _nz[j][nxtu+i]; + } + if (depends == 0) { + // state i does not appear differentiated in any equation + xk.flags[i] |= Omu_States::Algebraic; + xk.na++; + } + + // determine semi-bandwidths of dF/dx + dF/dxp + sbw = i - nd; // maximum lower sbw in this row + for (j = nd; j < i; j++) { + if (_nz[i][j] + _nz[i][nxtu+j] != 0) + break; + --sbw; + } + xk.sbw_l = max(sbw, xk.sbw_l); + + sbw = nxt - i - 1; // maximum upper sbw in this row + for (j = nxt - 1; j > i; j--) { + if (_nz[i][j] + _nz[i][nxtu+j] != 0) + break; + --sbw; + } + xk.sbw_u = max(sbw, xk.sbw_u); + } +} + +//-------------------------------------------------------------------------- +void Hqp_Omuses::setup_vars(int k, + VECP x, VECP xmin, VECP xmax, + VECP u, VECP umin, VECP umax, + VECP c, VECP cmin, VECP cmax) +{ + if (!_prg) { + error(E_NULL, "Hqp_Omuses::setup_vars"); + } + + int i, nx; + int K = _prg->ks()->dim - 1; + Omu_States &xk = _xs[k]; + Omu_Vars &uk = _us[k]; + Omu_Vars &ck = _cs[k]; + + xk.c_alloc = true; + if (k < K) { + xk.c_expand = true; + uk.c_alloc = true; + } + ck.c_alloc = true; + + _prg->setup(k, xk, uk, ck); + + xk.c_alloc = false; + xk.c_expand = false; + uk.c_alloc = false; + ck.c_alloc = false; + + nx = xk->dim - xk.nv; + alloc_vars(x, xmin, xmax, nx); + for (i = 0; i < nx; i++) { + x[i] = xk.initial[i]; + xmin[i] = xk.min[i]; + xmax[i] = xk.max[i]; + } + + alloc_vars(u, umin, umax, uk->dim); + v_copy(uk.initial, u); + v_copy(uk.min, umin); + v_copy(uk.max, umax); + + alloc_vars(c, cmin, cmax, ck->dim); + v_copy(ck.initial, c); + v_copy(ck.min, cmin); + v_copy(ck.max, cmax); + + init_vars(k, x, u); +} + +//-------------------------------------------------------------------------- +void Hqp_Omuses::init_vars(int k, VECP x, VECP u) +{ + if (!_prg) { + error(E_NULL, "Hqp_Omuses::init_vars"); + } + + int i; + Omu_States &xk = _xs[k]; + Omu_Vector &uk = _us[k]; + int nx = x->dim; + + v_copy(_xs[k].initial, xk); + nx = x->dim; + for (i = 0; i < nx; i++) + x[i] = xk[i]; + + v_copy(_us[k].initial, uk); + v_copy(uk, u); +} + +//-------------------------------------------------------------------------- +void Hqp_Omuses::setup_struct(int k, + VECP f0x, VECP f0u, int &f0_lin, + MATP fx, MATP fu, IVECP f_lin, + MATP cx, MATP cu, IVECP c_lin, + MATP Lxx, MATP Luu, MATP Lxu) +{ + // obtain discrete-time states and dF/dxt + Omu_States &xk = _xs[k]; + Omu_Vector &uk = _us[k]; + obtain_structure(k, xk, uk); + + // for now don't analyze sparse structure as required by HQP + // i.e. assume dense block matrices +} + +//-------------------------------------------------------------------------- +void Hqp_Omuses::init_simulation(int k, VECP x, VECP u) +{ + if (!_prg) { + error(E_NULL, "Hqp_Omuses::init_simulation"); + } + + int i; + int nx = x->dim; + int nu = u->dim; + Omu_States &xk = _xs[k]; + Omu_Vector &uk = _us[k]; + int nxt = xk->dim; + + for (i = 0; i < nx; i++) + xk[i] = x[i]; + for (i = nx; i < nxt; i++) + xk[i] = xk.initial[i]; + v_copy(u, uk); + + _prg->init_simulation(k, xk, uk); + if (xk->dim != nxt || uk->dim != nu) { + error(E_FORMAT, "Hqp_Omuses::init_simulation; modified vector sizes"); + } + + for (i = 0; i < nx; i++) + x[i] = xk[i]; + v_copy(uk, u); +} + +//-------------------------------------------------------------------------- +void Hqp_Omuses::update_vals(int k, const VECP x, const VECP u, + VECP f, Real &f0, VECP c) +{ + double val; + int i, kk, kkend; + int K = _prg->ks()->dim - 1; + Omu_States &xk = _xs[k]; + Omu_Vector &uk = _us[k]; + int nxt = xk->dim; + int nx = x->dim; + int nu = u->dim; + int nf = f->dim; + int nxtf = max(nxt, nf); + int nc = c->dim; + int nd = xk.nd; + + assert(nd >= 0); // obtain_structure() must have been called before + if (!_prg) { + error(E_NULL, "Hqp_Omuses::update_vals"); + } + + adouble af0; + adoublev ax(nxt); + adoublev au(nu); + adoublev af(nxtf); // size may increase or decrease in the next stage + adoublev ac(nc); + + v_resize(_xt, nxt); + + f0 = 0.0; + v_zero(c); + + // + // integrate the system equations over the stage + // calculate the discrete part for each sample of the stage + // + + if (k < K) { + _integrator->init_stage(k, xk, uk); + } + + // initial values for the integration + for (i = 0; i < nx; i++) + _xt[i] = x[i]; + for (i = nx; i < nxt; i++) + _xt[i] = xk.initial[i]; + v_copy(u, uk); + + kkend = (k < K)? _prg->ks(k+1): _prg->ks(k) + 1; + for (kk = _prg->ks(k); kk < kkend; kk++) { + + // backing store initial states + v_copy(_xt, xk); + + if (nxt > nd) { + _prg->consistic(kk, _prg->ts(kk), xk, uk, _xt); + _integrator->init_sample(kk, _prg->ts(kk), _prg->ts(kk+1)); + catchall(// try + _integrator->solve(kk, _prg->ts(kk), _prg->ts(kk+1), xk, uk, _prg, _xt), + // catch + f0 = Inf; + return); + } + + af0 <<= 0.0; + for (i = 0; i < nc; i++) + ac[i] <<= 0.0; + for (i = 0; i < nxt; i++) + af[i] = _xt[i]; + if (kk == kkend - 1) { + // default values for possible additional fs + for (i = nxt; i < nf; i++) + af[i] = 0.0; + } + ax <<= xk->ve; + au <<= uk->ve; + + _prg->update(kk, ax, au, af, af0, ac); + af0 *= _fscale; + + af0 >>= val; + f0 += val; + for (i = 0; i < nc; i++) { + ac[i] >>= val; + c[i] += val; + } + if (kk < kkend - 1) { + for (i = 0; i < nxt; i++) + af[i] >>= _xt[i]; + } + else { + for (i = 0; i < nf; i++) + af[i] >>= f[i]; + } + } +} + +//-------------------------------------------------------------------------- +void Hqp_Omuses::update_stage(int k, const VECP x, const VECP u, + VECP f, Real &f0, VECP c, + MATP fx, MATP fu, VECP f0x, VECP f0u, + MATP cx, MATP cu, + const VECP rf, const VECP rc, + MATP Lxx, MATP Luu, MATP Lxu) +{ + if (!_ad) { + Hqp_Docp_stub::update_stage(k, x, u, f, f0, c, + fx, fu, f0x, f0u, cx, cu, + rf, rc, Lxx, Luu, Lxu); + return; + } + + double val; + int i, j; + int K = _prg->ks()->dim - 1; + Omu_States &xk = _xs[k]; + Omu_Vector &uk = _us[k]; + int nxt = xk->dim; + int nx = x->dim; + int nu = u->dim; + int nf = f->dim; + int nxtf = max(nxt, nf); + int nc = c->dim; + int nd = xk.nd; + int kk, kkend; + + assert(nd >= 0); // init_vals() must have been called before + if (!_prg) { + error(E_NULL, "Hqp_Omuses::update_stage"); + } + + adouble af0; + adoublev ax(nxt); + adoublev au(nu); + adoublev af(nxtf); + adoublev ac(nc); + + int nxtu = nxt + nu; + int nindep = nxt + nu + nxtf; + int ndep = 1 + nc + nxtf; + + ad_realloc(ndep, nindep, nx+nu); + + f0 = 0.0; + v_zero(f0x); + v_zero(f0u); + v_zero(c); + m_zero(cx); + m_zero(cu); + + v_resize(_xt, nxt); + m_resize(_xtxk, nxt, nxt); + m_resize(_xtuk, nxt, nu); + m_resize(_Sx, nxt, nx); + m_resize(_Su, nxt, nu); + + // + // integrate the system equations over the stage + // calculate the criterion for each sample within the stage + // + + if (k < K) + _integrator->init_stage(k, xk, uk, true); + + // initial values for the integration + m_zero(_Sx); + m_zero(_Su); + for (i = 0; i < nx; i++) { + _xt[i] = x[i]; + _Sx[i][i] = 1.0; + } + for (i = nx; i < nxt; i++) + _xt[i] = xk.initial[i]; + v_copy(u, uk); + + kkend = (k < K)? _prg->ks(k+1): _prg->ks(k) + 1; + for (kk = _prg->ks(k); kk < kkend; kk++) { + + // backing store initial states of the sample period + // initialize seed derivatives for the initial states + + v_copy(_xt, xk); + m_zero(_X); + + if (nxt > nd) { + // solve continuous-time equations + m_zero(_xtxk); + m_zero(_xtuk); + _prg->consistic(kk, _prg->ts(kk), xk, uk, _xt, _xtxk, _xtuk); + m_mlt(_xtxk, _Sx, _IS); + m_copy(_IS, _Sx); + m_mlt(_xtxk, _Su, _IS); + m_add(_IS, _xtuk, _Su); + for (i = 0; i < nxt; i++) { + for (j = 0; j < nx; j++) { + _X[i][j] = _Sx[i][j]; + } + for (j = 0; j < nu; j++) { + _X[i][nx + j] = _Su[i][j]; + } + } + _integrator->init_sample(kk, _prg->ts(kk), _prg->ts(kk+1)); + catchall(// try + _integrator->solve(kk, _prg->ts(kk), _prg->ts(kk+1), + xk, uk, _prg, _xt, _Sx, _Su), + // catch + f0 = Inf; + return); + } + else if (kk > _prg->ks(k)) { + // second or further sample of stage without continuous-time equations + for (i = 0; i < nxt; i++) { + for (j = 0; j < nx; j++) { + _X[i][j] = _Sx[i][j]; + } + for (j = 0; j < nu; j++) { + _X[i][nx + j] = _Su[i][j]; + } + } + } + else { + // first sample of stage without continuous-time equations + for (i = 0; i < nx; i++) { + _X[i][i] = 1.0; + } + } + + // init seed derivatives for control parameters + for (i = 0; i < nu; i++) { + _X[nxt + i][nx + i] = 1.0; + } + + // + // update the criterion, constraints, and discrete states + // + + // initialize dependend variables + af0 = 0.0; + ndep = 1; + for (i = 0; i < nc; i++) + ac[i] = 0.0; + ndep += nc; + if (kk < kkend - 1) { + // intermediate sample + for (i = 0; i < nxt; i++) + af[i] = _xt[i]; + ndep += nxt; + } + else { + // final sample + for (i = 0; i < nxt; i++) + af[i] = _xt[i]; + for (i = nxt; i < nf; i++) + af[i] = 0.0; + ndep += nf; + } + + trace_on(2); + + // initialize variable vector + nindep = 0; + ax <<= xk->ve; + for (i = 0; i < nxt; i++) { + _x[i] = xk[i]; + } + nindep += nxt; + au <<= uk->ve; + for (i = 0; i < nu; i++) { + _x[nxt + i] = uk[i]; + } + nindep += nu; + for (i = nd; i < nxt; i++) { + af[i] <<= _xt[i]; + _x[nxtu - nd + i] = _xt[i]; + } + nindep += nxt - nd; + // discrete-time states are constant, that is why + // no extra independend variables necessary + for (i = 0; i < nd; i++) + af[i] = ax[i]; + + _prg->update(kk, ax, au, af, af0, ac); + af0 *= _fscale; + + af0 >>= val; + f0 += val; + for (i = 0; i < nc; i++) { + ac[i] >>= val; + c[i] += val; + } + if (kk < kkend - 1) { + for (i = 0; i < nxt; i++) + af[i] >>= _xt[i]; + } + else { + for (i = 0; i < nf; i++) + af[i] >>= f[i]; + } + + trace_off(); + + // initialize seed derivatives for final continuous-time states + for (i = nd; i < nxt; i++) { + for (j = 0; j < nx; j++) { + _X[nxtu - nd + i][j] = _Sx[i][j]; + } + for (j = 0; j < nu; j++) { + _X[nxtu - nd + i][nx + j] = _Su[i][j]; + } + } + + forward(2, ndep, nindep, nx+nu, _x->ve, _X->me, _y->ve, _Y->me); + + for (j = 0; j < nx; j++) + f0x[j] += _Y[0][j]; + for (j = 0; j < nu; j++) + f0u[j] += _Y[0][nx + j]; + + for (i = 0; i < nc; i++) { + for (j = 0; j < nx; j++) + cx[i][j] += _Y[1 + i][j]; + for (j = 0; j < nu; j++) + cu[i][j] += _Y[1 + i][nx + j]; + } + + if (kk < kkend - 1) { + for (i = 0; i < nxt; i++) { + for (j = 0; j < nx; j++) + _Sx[i][j] = _Y[1 + nc + i][j]; + for (j = 0; j < nu; j++) + _Su[i][j] = _Y[1 + nc + i][nx + j]; + } + } + else { + for (i = 0; i < nf; i++) { + for (j = 0; j < nx; j++) + fx[i][j] = _Y[1 + nc + i][j]; + for (j = 0; j < nu; j++) + fu[i][j] = _Y[1 + nc + i][nx + j]; + } + } + } +} + + +//======================================================================== diff --git a/omu/Hqp_Omuses.h b/omu/Hqp_Omuses.h new file mode 100644 index 0000000..af3205b --- /dev/null +++ b/omu/Hqp_Omuses.h @@ -0,0 +1,126 @@ +/* + * Hqp_Omuses.h -- + * -- multi stage optimal control problems described by DAE's + * + * rf, 7/27/96 + */ + +/* + Copyright (C) 1997--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Hqp_Omuses_H +#define Hqp_Omuses_H + +#include "Hqp_Docp_stub.h" + +#include +#include +#include + +class Omu_Program; +class Omu_Integrator; +class Omu_Vars; +class Omu_Vector; +class Omu_States; + +//-------------------------------------------------------------------------- +class Hqp_Omuses: public Hqp_Docp_stub { + + public: + + Hqp_Omuses(); + ~Hqp_Omuses(); + char *name() {return "Omuses";} + + int setup_stages(IF_DEF_ARGS); + + protected: + + If_List _ifList; + Omu_Program *_prg; + Omu_Integrator *_integrator; + + bool _stages_ok; // setup_stages() was called separately + VECP _xt; // initial states of a sample period + MATP _xtxk; // dxt/dxk + MATP _xtuk; // dxt/duk + MATP _Sx; // sensitivity for x + MATP _IS; // help matrix + MATP _Su; // sensitivity for u + bool _ad; // flag about use of automatic differentiation + double _fscale; // scaling of the criterion + + // define interface of Hqp_Docp_stub + void setup_horizon(int &k0, int &kf); + + void setup_vars(int k, + VECP x, VECP xmin, VECP xmax, + VECP u, VECP umin, VECP umax, + VECP c, VECP cmin, VECP cmax); + + void setup_struct(int k, + VECP f0x, VECP f0u, int &f0_lin, + MATP fx, MATP fu, IVECP f_lin, + MATP cx, MATP cu, IVECP c_lin, + MATP Lxx, MATP Luu, MATP Lxu); + + void init_simulation(int k, + VECP x, VECP u); + + void update_vals(int k, const VECP x, const VECP u, + VECP f, Real &f0, VECP c); + + void update_stage(int k, const VECP x, const VECP u, + VECP f, Real &f0, VECP c, + MATP fx, MATP fu, VECP f0x, VECP f0u, + MATP cx, MATP cu, + const VECP rf, const VECP rc, + MATP Lxx, MATP Luu, MATP Lxu); + + // further methods + void init_vars(int k, + VECP x, VECP u); + + void obtain_structure(int k, + Omu_States &xk, const Omu_Vector &uk); + + Omu_States *_xs; // state information from problem setup + Omu_Vars *_us; // control information from problem setup + Omu_Vars *_cs; // constraint information from problem setup + + // variables for ADOL-C + + void ad_alloc(int ndep, int nindep, int npar); + void ad_realloc(int ndep, int nindep, int npar); + void ad_free(); + int _max_ndep; + int _max_nindep; + int _max_npar; + + VECP _x; + VECP _y; + MATP _X; + MATP _Y; + MATP _U; + double ***_Z3; + short **_nz; +}; + +#endif + diff --git a/omu/Makefile b/omu/Makefile new file mode 100644 index 0000000..f0ba8b0 --- /dev/null +++ b/omu/Makefile @@ -0,0 +1,53 @@ +# Makefile for omu +# ("makedepend" may be used for depencies) + +include ../makedirs +include ../makedefs + +CCDEFS = -I. $(MES_INCDIR) $(TCL_INCDIR) $(IF_INCDIR) \ + $(HQP_INCDIR) $(ADOL_INCDIR) $(OMU_DEFS) + +SRCS = Omu_Init.C \ + Hqp_Docp_stub.C \ + Hqp_Omuses.C \ + Omu_Vector.C \ + Omu_Vars.C \ + Omu_Program.C \ + Omu_Integrator.C \ + Omu_IntODE.C \ + Omu_IntEuler.C \ + Omu_IntRK4.C \ + Omu_IntOdeTs.C \ + Omu_IntDopri5.C \ + Omu_IntIMP.C \ + Omu_IntSDIRK.C \ + $(OMU_INTRKSUITE_C) \ + $(OMU_INTDASPK_C) + +OBJS = $(SRCS:.C=.o) $(RKSUITE_O) + +LIBRARY = omu + +lib: $(OBJS) $(DASPK) Makefile + rm -f $(LIB_PREFIX)$(LIBRARY)$(MKLIB_SUFFIX) + $(LD)$(LIB_PREFIX)$(LIBRARY)$(MKLIB_SUFFIX) $(OBJS) \ + ../adol-c/SRC/*.o ../adol-c/SRC/*/*.o $(DASPK_OBJS) + $(RANLIB) $(LIB_PREFIX)$(LIBRARY)$(LIB_SUFFIX) + +daspk: + PWD=`pwd`; cd ../daspk/examples/DM; make heat heatilu; cd $(PWD) + +$(RKSUITE_O): $(RKSUITE_O:.o=.f) + PWD=`pwd`; cd `dirname $(RKSUITE_O)`; \ + $(FORTRAN_COMP) $(FORTRAN_FLAGS) -c rksuite.f; cd $(PWD) + +.C.o: + $(CXX) -c $(CXXFLAGS) $(CCDEFS) $< + +clean: + rm -f *.o *.obj $(LIB_PREFIX)omu.* *~ + +depend: + makedepend -- $(CCFLAGS) -- $(SRCS) + +# DO NOT DELETE THIS LINE -- make depend depends on it. diff --git a/omu/Omu_Init.C b/omu/Omu_Init.C new file mode 100644 index 0000000..32e1b8b --- /dev/null +++ b/omu/Omu_Init.C @@ -0,0 +1,96 @@ +/* + * Omu_Init: initialize the Omuses package + * + * rf, 1/10/97 + * + * rf, 03/22/00 + * add support for Tcl package handling + */ + +/* + Copyright (C) 1997--2001 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#include "Hqp_Omuses.h" + +#ifdef IF_CLASS_STATIC +//-------------------------------------------------------------------------- +// ensure linkage of modules +//-------------------------------------------------------------------------- +#include "Omu_IntEuler.h" +#include "Omu_IntRK4.h" +#include "Omu_IntOdeTs.h" +#include "Omu_IntDopri5.h" +#include "Omu_IntIMP.h" +#include "Omu_IntSDIRK.h" +#ifdef OMU_WITH_FORTRAN +#include "Omu_IntRKsuite.h" +#include "Omu_IntDASPK.h" +#endif + +static void Omu_ClassAlloc() +{ + IF_CLASS_ALLOC("Euler", Omu_IntEuler, Omu_Integrator); + IF_CLASS_ALLOC("RK4", Omu_IntRK4, Omu_Integrator); + IF_CLASS_ALLOC("OdeTs", Omu_IntOdeTs, Omu_Integrator); + IF_CLASS_ALLOC("Dopri5", Omu_IntDopri5, Omu_Integrator); + IF_CLASS_ALLOC("IMP", Omu_IntIMP, Omu_Integrator); + IF_CLASS_ALLOC("SDIRK", Omu_IntSDIRK, Omu_Integrator); +#ifdef OMU_WITH_FORTRAN + IF_CLASS_ALLOC("DASPK", Omu_IntDASPK, Omu_Integrator); + IF_CLASS_ALLOC("RKsuite", Omu_IntRKsuite, Omu_Integrator); +#endif +} +#endif + +//-------------------------------------------------------------------------- +const char *Omu_Version = VERSION; + +static int Omu_VersionCmd(int, char *[], char **result) +{ + *result = (char *)Omu_Version; + return IF_OK; +} + +//-------------------------------------------------------------------------- +extern "C" int Omu_Init(Tcl_Interp *interp) +{ + // provide Tcl package Omuses + if (Tcl_PkgRequire(interp, "Tcl", "8.0", 0) == NULL || + Tcl_PkgProvide(interp, "Omuses", (char *)Omu_Version) != TCL_OK) { + return TCL_ERROR; + } + + // initialize global reference to Tcl interpreter + theInterp = interp; + + new If_Proc("omu_version", &Omu_VersionCmd); + + // allocate interface modules +# ifdef IF_CLASS_STATIC + Omu_ClassAlloc(); +# endif + + // create instance of Hqp_Omuses + new Hqp_Omuses; + + return TCL_OK; +} diff --git a/omu/Omu_IntDASPK.C b/omu/Omu_IntDASPK.C new file mode 100644 index 0000000..b581fd0 --- /dev/null +++ b/omu/Omu_IntDASPK.C @@ -0,0 +1,747 @@ +/* + * Omu_IntDASPK.C -- + * -- class implementation + * + * rf, 10/2/96 + */ + +/* + Copyright (C) 1996--2000 Ruediger Franke and Hartmut Linke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#include +#include +#include + +#include "Omu_IntDASPK.h" + +IF_CLASS_DEFINE("DASPK", Omu_IntDASPK, Omu_Integrator); + +/* + * functions for communication with DASPK + */ + +// fuctions defined by Omu_IntDASPK +typedef void +(res_t)(freal *T, freal *Y, freal *XPRIME, freal *CJ, + freal *DELTA, fint *IRES, freal *RPAR, fint *IPAR, + freal *SENPAR); + +typedef void +(jac_t)(freal *T, freal *Y, freal *YPRIME, + freal *PD, freal *CJ, freal *RPAR, fint *IPAR, + freal *SENPAR, fint *IJAC); + +typedef void +(kryjac_t)(res_t *RES, fint *IRES, fint *NEQ, freal *T, freal *Y, + freal *YPRIME, freal *REWT, freal *SAVR, freal *WK, + freal *H, freal *CJ, freal *WP, fint *IWP, fint *IERR, + freal *RPAR, fint *IPAR, freal *SENPAR); + +typedef void +(psol_t)(fint *NEQ, freal *T, freal *Y, freal *YPRIME, freal *SAVR, + freal *WK, freal *CJ, freal *WGHT, freal *WP, fint *IWP, + freal *B, freal *EPLIN, fint *IER, freal *RPAR, fint *IPAR, + freal *SENPAR); + +typedef void +(g_res_t)(/* currently not of interest */); + +extern "C" { + + void dspsetup_(fint *NEQ, fint *LWP, fint *LIWP, freal *RPAR, + fint *IPAR, fint *IERR, fint *LWP_MIN, + fint *LIWP_MIN); + + void ddaspk_(res_t *RES, fint *NEQ, freal *T, freal *Y, freal *YPRIME, + freal *TOUT, fint *INFO, freal *RTOL, freal *ATOL, + fint *IDID, freal *RWORK, fint *LRW, fint *IWORK, fint *LIW, + freal *RPAR, fint *IPAR, jac_t *JAC, psol_t *PSOL, + freal *SENPAR, g_res_t *G_RES); + + kryjac_t dbanja_; // iterative solver: generate banded preconditioner + psol_t dbanps_; // iterative solver: solve linear system + kryjac_t djacilu_; // iterative solver: generate ilu preconditioner + psol_t dpsolilu_; // iterative solver: solve linear system +} + +Omu_IntDASPK *theOmu_IntDASPK; + +//-------------------------------------------------------------------------- +static void RES(freal *t, freal *y, freal *yprime, freal *, + freal *delta, fint *ires, freal *rpar, fint *ipar, + freal *senpar) +{ + theOmu_IntDASPK->res(t, y, yprime, delta, ires, rpar, ipar, senpar); +} + +//-------------------------------------------------------------------------- +static void PSOL() +{ + error(E_INTERN, "DASPK, which called PSOL"); +} + +//-------------------------------------------------------------------------- +static void G_RES() +{ + error(E_INTERN, "DASPK, which called G_RES"); +} + +//-------------------------------------------------------------------------- +static void JAC(freal *t, freal *y, freal *yprime, + freal *pd, freal *cj, freal *rpar, fint *ipar, + freal *senpar, fint *ijac) +{ + theOmu_IntDASPK->jac(t, y, yprime, pd, cj, rpar, ipar, senpar, ijac); +} + +//-------------------------------------------------------------------------- +Omu_IntDASPK::Omu_IntDASPK() +{ + theOmu_IntDASPK = this; + + _cx = v_get(1); + _cu = v_get(1); + _cxp = v_get(1); + _cF = v_get(1); + _cFx = m_get(1, 1); + _cFu = m_get(1, 1); + _cFxp = m_get(1, 1); + _Xx = m_get(1, 1); + _Xu = m_get(1, 1); + _Xxp = m_get(1, 1); + _Xup = m_get(1, 1); + _Yx = m_get(1, 1); + _Yu = m_get(1, 1); + + _ml = 0; + _mu = 0; + _y = v_get(1); + _yprime = v_get(1); + _info = iv_get(30); + _rwork = v_get(1); + _iwork = iv_get(1); + _rpar = v_get(1); + _ipar = iv_get(1); + _senpar = v_get(1); + + _banded = true; + _krylov = false; + _krylov_prec = false; + + _nsteps = 0; + + _lwp = 0; + _liwp = 0; + _lwp_basic = 0; + + _jac_sbw = -1; // i.e. automatic detection + _ifList.append(new If_Int("prg_int_jac_sbw", &_jac_sbw)); + _ifList.append(new If_Bool("prg_int_banded", &_banded)); + _ifList.append(new If_Bool("prg_int_krylov", &_krylov)); + _ifList.append(new If_Bool("prg_int_krylov_prec", &_krylov_prec)); + _ifList.append(new If_Int("prg_int_nsteps", &_nsteps)); + +} + +//-------------------------------------------------------------------------- +Omu_IntDASPK::~Omu_IntDASPK() +{ + v_free(_cx); + v_free(_cu); + v_free(_cxp); + v_free(_cF); + m_free(_cFx); + m_free(_cFu); + m_free(_cFxp); + m_free(_Xx); + m_free(_Xu); + m_free(_Xxp); + m_free(_Xup); + m_free(_Yx); + m_free(_Yu); + + v_free(_y); + v_free(_yprime); + iv_free(_info); + v_free(_rwork); + iv_free(_iwork); + v_free(_rpar); + iv_free(_ipar); + v_free(_senpar); +} + +//-------------------------------------------------------------------------- +void Omu_IntDASPK::init_stage(int k, + const Omu_States &x, const Omu_Vector &u, + bool sa) +{ + + Omu_Integrator::init_stage(k, x, u, sa); + + if (_jac_sbw >= 0) { + // take user-defined value + _ml = _mu = _jac_sbw; + _banded_solver = _banded; + } + else { + _ml = x.sbw_l; + _mu = x.sbw_u; + + _banded_solver = _banded; + // disable banded solver if full solver appears more efficient + if (_ml+_ml+_mu >= _n) + _banded_solver = false; + } + + realloc(); + init_options(x); +} + +//-------------------------------------------------------------------------- +void Omu_IntDASPK::realloc() +{ + + int kmp, maxl, maxord, neq, nrmax; + + + if (_cx->dim == _nd + _n && _cu->dim == _nu) + return; + + // + // realloc variables for low level _sys->continuous callback + // + v_resize(_cx, _nd + _n); + v_resize(_cu, _nu); + v_resize(_cxp, _nd + _n); + v_resize(_cF, _nd + _n); + m_resize(_cFx, _nd + _n, _nd + _n); + m_resize(_cFu, _nd + _n, _nu); + m_resize(_cFxp, _nd + _n, _nd + _n); + m_resize(_Xx, _nd + _n, _nx); + m_resize(_Xu, _nd + _n, _nu); + m_resize(_Xxp, _nd + _n, _nx); + m_resize(_Xup, _nd + _n, _nu); + m_resize(_Yx, _nd + _n, _nx); + m_resize(_Yu, _nd + _n, _nu); + + // + // re-allocate variables for DASPK + // + + neq = _n * (1 + _nx + _nu); + + v_resize(_y, neq); + v_resize(_yprime, neq); + v_resize(_senpar, _nd + _nu); + + if (!_krylov) { + // + // direct matrix solver + // + + int itmp1, itmp3; + int lrw = 50 + (5 + 4)*neq; + // if _info[16-1] = 1, i.e. no error test for algebraic variables: + lrw += neq; + if (_banded_solver) { + lrw += (2*_ml + _mu + 1)*_n; + // if _info[5-1] = 0, i.e. no analytical Jacobian: + itmp1 = 2*(_n/(_ml+_mu+1)+1); + } + else { + lrw += _n*_n; + itmp1 = 0; + } + // if _info[20-1] < 2, i.e. no analytical sensitivity equations + itmp3 = 4*_n; + lrw += itmp1 > itmp3? itmp1: itmp3; + + v_resize(_rwork, lrw); + iv_resize(_iwork, 40 + neq + _n); + + // store initial states and controls in RPAR/IPAR as proposed by DASPK + v_resize(_rpar, _nd + _n + _nu); + iv_resize(_ipar, _nd + _n + _nu); + } + else { + // + // iterative solver + // + + v_resize(_rpar, _nd + _n + _nu); + iv_resize(_ipar, 20 + _nd + _n + _nu); + + neq = _n * (1 + _nx + _nu); + + // daspk standard settings + maxl = min(5,neq); + kmp = maxl; + nrmax = 5; + maxord = 5; + + _lwp_basic = 50 + max(maxord+5,9)*neq + (maxl+3)*maxl+1; + _lwp = 0; + _liwp = 0; + + /* + if(_sa) + _lwp_basic += (maxl+3+max(0,min(1,maxl-kmp)))*neq/(_nd + _n + _nu + 1); + else + */ + + _lwp_basic += (maxl+3+max(0,min(1,maxl-kmp)))*neq; + + if (!_krylov_prec) { + v_resize(_rwork, _lwp_basic + _lwp); + iv_resize(_iwork, 40 + 4*_n); + } + else { + if (_banded_solver) { + // banded preconditioner + _lwp = (2*_ml + _mu + 1)*neq + 2*((neq/(_ml + _mu+1)) + 1); + _liwp = neq; + + v_resize(_rwork, _lwp_basic + _lwp); + iv_resize(_iwork, 40+2*neq+1+_liwp); + } + else { + // parameters for incomplete LU factorization + v_resize(_rwork, _lwp_basic + _lwp); + iv_resize(_iwork, 40+2*neq+1+_liwp); + } + } + } + + v_zero(_rwork); + iv_zero(_iwork); + v_zero(_rpar); + iv_zero(_ipar); +} + +//-------------------------------------------------------------------------- +void Omu_IntDASPK::init_options(const Omu_States &x) +{ + + int i, neq, n; + + iv_zero(_info); // lots of defaults + + if (!_krylov) { + _info[5-1] = 1; // use analytical Jacobian + + if (_banded_solver) { + _info[6-1] = 1; + _iwork[1-1] = _ml; + _iwork[2-1] = _mu; + } + } + else { + _info[12-1] = 1; // use Krylov method + + neq = _n * (1 + _nx + _nu); + + if (!_krylov_prec) { + _info[15-1] = 0; // don't use preconditioner + } + else { + _info[15-1] = 1; + + if (_banded_solver) { + _ipar[1-1] = _ml; + _ipar[2-1] = _mu; + } + else { + // parameters for incomplete LU factorization + + fint lwp_act, liwp_act, IDID; + + n = (int) max(1.0,0.25*_n); + + _ipar[1-1] = min(_ml,n); + _ipar[2-1] = min(_mu,n); + _ipar[3-1] = 2; + _ipar[4-1] = 2; + _ipar[5-1] = 1; + _ipar[6-1] = n; + _ipar[7-1] = 0; + _ipar[8-1] = 1; + _ipar[9-1] = 0; + _ipar[10-1] = 0; + _ipar[11-1] = 1; + + _rpar[1-1] = 0.001; + _rpar[2-1] = 0.01; + + lwp_act = _lwp; + liwp_act = _liwp; + + // check + dspsetup_(&neq, &lwp_act, &liwp_act, _rpar->ve, _ipar->ive, &IDID, + &_lwp, &_liwp); + + if(_lwp != lwp_act) + v_resize(_rwork, 50 + 10*neq + (neq+3)*neq + (neq+3)*neq + 1 + _lwp); + v_zero(_rwork); + + if(_liwp != liwp_act) + iv_resize(_iwork, 40+2*neq+1+_liwp); + iv_zero(_iwork); + } + } + _iwork[27-1] = _lwp; + _iwork[28-1] = _liwp; + } + + if (x.na > 0) { + + // assume inconsistent initial algebraic vars and derivatives + // if algebraic states are present + // todo: check if this is valid and check other methods + // to treat DAE initialization problem + _info[11-1] = 1; + int LID = 40; + for (i = 0; i < _n; i++) { + if (x.flags[_nd+i] & Omu_States::Algebraic) + _iwork[LID + i] = -1; // indicate algebraic state + else + _iwork[LID + i] = 2; // indicate fixed state variable + } + } + + // sensitivity options + _info[20-1] = 2; // res() provides sensitivity equations + _info[22-1] = _nd + _nu; // number of parameters appearing in res() + _info[23-1] = !_serr; // exclude sensitivities from error test + _info[25-1] = 2; // staggert direct method +} + +//-------------------------------------------------------------------------- +void Omu_IntDASPK::solve(int kk, double tstart, double tend, + const Omu_States &x, const Omu_Vector &u, + Omu_Program *sys, VECP xt, + MATP Sx, MATP Su) +{ + + int i, j; + + _sys = sys; // propagate to res() and jac() + + // _stepsize overrides _nsteps + int nsteps = _nsteps; + if (_stepsize > 0.0) + nsteps = (int)ceil((tend - tstart) / _stepsize); + + if (!_sys->has_low_level_continuous() && nsteps == 0) { + // Don't use analytical Jacobian if not explicitly given + // and if variable step size is enabled. DASPK seems to adapt + // its behavior assuming a cheap analytical Jacobian evaluation, + // which is not true for ADOL-C. + _info[5-1] = 0; + } + + // + // init Jacobians + // + + m_zero(_cFx); + m_zero(_cFu); + m_zero(_cFxp); + + // + // init DASPK variables + // + + fint NEQ; + freal T = tstart; + freal *Y = _y->ve; + freal *YPRIME = _yprime->ve; + freal TOUT = tend; + fint *INFO = _info->ive; + freal RTOL = _rtol; + freal ATOL = _atol; + fint IDID; + freal *RWORK = _rwork->ve; + fint LRW = _rwork->dim; + fint *IWORK = _iwork->ive; + fint LIW = _iwork->dim; + freal *RPAR = _rpar->ve; + fint *IPAR = _ipar->ive; + jac_t *JAC_P = &JAC; + psol_t *PSOL_P = (psol_t*)&PSOL; + freal *SENPAR = _senpar->ve; + g_res_t *G_RES_P = &G_RES; + + if (_krylov) { + if (!_krylov_prec) { + PSOL_P = (psol_t *)&dpsolilu_; + } + else { + if (_banded_solver) { + JAC_P = (jac_t *)&dbanja_; + PSOL_P = (psol_t *)&dbanps_; + } + else { + JAC_P = (jac_t *)&djacilu_; + PSOL_P = (psol_t *)&dpsolilu_; + } + } + } + + v_zero(_y); + v_zero(_yprime); + + for (i = 0; i < _nd; i++) { + _senpar[i] = xt[i]; + } + for (i = 0; i < _n; i++) { + _y[i] = xt[_nd + i]; // initial states + } + for (i = 0; i < _nu; i++) { + _senpar[_nd + i] = u[i]; + } + + if (_sa) { + for (i = 0; i < _n; i++) { + for (j = 0; j < _nx; j++) { + _y[(1 + j) * _n + i] = Sx[_nd + i][j]; + } + for (j = 0; j < _nu; j++) { + _y[(1 + _nx + j) * _n + i] = Su[_nd + i][j]; + } + } + } + + _info[1-1] = 0; // restart new problem + // Restarting a new problem might not be needed for multiple + // sample periods in one stage. + // But then the sensitivity error check should be enabled + // (_serr, which goes to info[23-1])! + // This check seems to be less important if problem is restarted. + + //_info[4-1] = 1; // don't go beyond TOUT + //_rwork[1-1] = TOUT; + + // take user defined number of steps if nsteps > 0 + if (nsteps > 0) { + //_info[3-1] = 1; // return after each step + RTOL = 1e37; // disable error test + ATOL = 1e37; + _info[7-1] = 1; // user defined max. step size + _rwork[2-1] = (tend - tstart)/nsteps; // maximal step size + _info[8-1] = 1; // user defined initial step size + _rwork[3-1] = (tend - tstart)/nsteps; // initial step size + //_info[9-1] = 1; // restrict maxord + //_iwork[3-1] = 1; // maxord=1 + } + + NEQ = _n; + if (_sa) { + _info[19-1] = _nx + _nu; + NEQ += _n * _info[19-1]; + } + else { + _info[19-1] = 0; + } + + // + // integrate the system equations over the stage + // + while (true) { + ddaspk_(&RES, &NEQ, &T, Y, YPRIME, &TOUT, INFO, &RTOL, &ATOL, + &IDID, RWORK, &LRW, IWORK, &LIW, RPAR, IPAR, + JAC_P, PSOL_P, SENPAR, G_RES_P); + if (IDID != -1) + break; + _info[1-1] = 1; + } + + if (IDID != 3 || T != TOUT) { + /* + fprintf(stderr, "equations: %d\n",NEQ); + v_foutput(stderr, x); + v_foutput(stderr, u); + v_foutput(stderr, _yprime); + v_foutput(stderr, _y); + */ + error(E_UNKNOWN, + "Omu_IntDASPK::solve that failed in calling DASPK"); + } + + // + // read and return results + // + + for (i = 0; i < _n; i++) { + xt[_nd + i] = _y[i]; + } + + if (_sa) { + for (i = 0; i < _n; i++) { + for (j = 0; j < _nx; j++) { + Sx[_nd + i][j] = _y[(1 + j) * _n + i]; + } + for (j = 0; j < _nu; j++) { + Su[_nd + i][j] = _y[(1 + _nx + j) * _n + i]; + } + } + } +} + +//-------------------------------------------------------------------------- +void Omu_IntDASPK::res(freal *t, freal *y, freal *yprime, + freal *delta, fint *ires, freal *rpar, fint *, + freal *senpar) +{ + int i, j; + + // form vectors of independent variables + + for (i = 0; i < _nd; i++) { + _cx[i] = senpar[i]; + _cxp[i] = 0.0; + } + for (i = 0; i < _n; i++) { + _cx[_nd + i] = y[i]; + _cxp[_nd + i] = yprime[i]; + } + for (i = 0; i < _nu; i++) { + _cu[i] = senpar[_nd + i]; + } + + // evaluate residual + + if (*ires == 1) + _sys->continuous(_kk, *t, _cx, _cu, _cxp, _cF, _cFx, _cFu, _cFxp); + else + _sys->continuous(_kk, *t, _cx, _cu, _cxp, _cF); + + // read and return result + for (i = 0; i < _n; i++) + delta[i] = _cF[_nd+i]; + + if (*ires == 1) { + // init seed derivatives + m_zero(_Xx); + m_zero(_Xu); + m_zero(_Xxp); + m_zero(_Xup); + for (i = 0; i < _nd; i++) { + _Xx[i][i] = 1.0; + } + for (i = 0; i < _n; i++) { + for (j = 0; j < _nx; j++) { + _Xx[_nd + i][j] = y[(1 + j) * _n + i]; + _Xxp[_nd + i][j] = yprime[(1 + j) * _n + i]; + } + for (j = 0; j < _nu; j++) { + _Xu[_nd + i][j] = y[(1 + _nx + j) * _n + i]; + _Xup[_nd + i][j] = yprime[(1 + _nx + j) * _n + i]; + } + } + + // _Yx = dF/dxk = dF/dx * dx/dxk + dF/dxp * dxp/dxk + m_mlt(_cFx, _Xx, _Yx); + m_mlt(_cFxp, _Xxp, _Xx); + m_add(_Yx, _Xx, _Yx); + + // _Yu = dF/duk = dF/dx * dx/duk + dF/dxp * dxp/duk + dF/duk + m_mlt(_cFx, _Xu, _Yu); + m_mlt(_cFxp, _Xup, _Xu); + m_add(_Yu, _Xu, _Yu); + m_add(_cFu, _Yu, _Yu); + + // write result + for (i = 0; i < _n; i++) { + for (j = 0; j < _nx; j++) { + delta[(1 + j) * _n + i] = _Yx[_nd + i][j]; + } + for (j = 0; j < _nu; j++) { + delta[(1 + _nx + j) * _n + i] = _Yu[_nd + i][j]; + } + } + } + + _res_evals++; + if (*ires == 1) + _sen_evals++; +} + +//-------------------------------------------------------------------------- +void Omu_IntDASPK::jac(freal *t, freal *y, freal *yprime, + freal *pd, freal *cj, freal *rpar, fint *, + freal *senpar, fint *ijac) +{ + if (*ijac != 0) + // don't know how to treat + error(E_INTERN, "Omu_IntDASPK::jac"); + + int i, j; + + // form vectors of independent variables + + for (i = 0; i < _nd; i++) { + _cx[i] = senpar[i]; + _cxp[i] = 0.0; + } + for (i = 0; i < _n; i++) { + _cx[_nd + i] = y[i]; + _cxp[_nd + i] = yprime[i]; + } + for (i = 0; i < _nu; i++) { + _cu[i] = senpar[_nd + i]; + } + + // evaluate residuals and Jacobians + + _sys->continuous(_kk, *t, _cx, _cu, _cxp, _cF, _cFx, _cFu, _cFxp); + + // read and return results + + if (!_banded_solver) + // full Jacobian + for (i = 0; i < _n; i++) { + for (j = 0; j < _n; j++) { + pd[i + _n * j] = _cFx[_nd+i][_nd+j] + *cj * _cFxp[_nd+i][_nd+j]; + } + } + else { + // banded Jacobian + int j_start, j_end; + int nb = 2*_ml + _mu + 1; + int irow; + for (i = 0; i < _n; i++) { + j_start = i - _ml; + j_start = max(j_start, 0); + j_end = i + _mu + 1; + j_end = min(j_end, _n); + for (j = j_start; j < j_end; j++) { + irow = i - j + _ml + _mu; + pd[irow + nb * j] = _cFx[_nd+i][_nd+j] + *cj * _cFxp[_nd+i][_nd+j]; + } + } + } + + _jac_evals++; +} + + +//======================================================================== diff --git a/omu/Omu_IntDASPK.h b/omu/Omu_IntDASPK.h new file mode 100644 index 0000000..cc7bcbc --- /dev/null +++ b/omu/Omu_IntDASPK.h @@ -0,0 +1,153 @@ +/* + * Omu_IntDASPK.h -- + * -- integrate DAE over a stage using DASPK3.0 + * (derived from earlier Omu_IntDASPKSO implementation) + * + * rf, 10/2/96 + */ + +/* + Copyright (C) 1996--2000 Ruediger Franke and Hartmut Linke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Omu_IntDASPK_H +#define Omu_IntDASPK_H + +#include "Omu_Integrator.h" + +/* + * FORTRAN data types + */ + +#ifdef fint +#undef fint +#endif +#define fint int + +#ifdef freal +#undef freal +#endif +#define freal double + +//-------------------------------------------------------------------------- +class Omu_IntDASPK: public Omu_Integrator { + + public: + + Omu_IntDASPK(); + ~Omu_IntDASPK(); + + char *name() {return "DASPK";} + + // override interface routine of Omu_Integrator + void init_stage(int k, + const Omu_States &x, const Omu_Vector &u, + bool sa); + void solve(int kk, double tstart, double tend, + const Omu_States &x, const Omu_Vector &u, + Omu_Program *sys, VECP xt, + MATP Sx, MATP Su); + + // routines called by DASPK + void res(freal *t, freal *x, freal *xprime, + freal *delta, fint *ires, freal *rpar, fint *ipar, + freal *senpar); + + void jac(freal *t, freal *y, freal *yprime, + freal *pd, freal *cj, freal *rpar, fint *ipar, + freal *senpar, fint *ijac); + + private: + + void realloc(); + void init_options(const Omu_States &x); + + // backing store sys and current stage + Omu_Program *_sys; + + // variables for DASPK + int _mu; // upper semi-bandwidth + int _ml; // lower semi-bandwidth + int _lwp; + int _liwp; + int _lwp_basic; + + VECP _y; + VECP _yprime; + IVECP _info; + VECP _rwork; + IVECP _iwork; + VECP _rpar; + IVECP _ipar; + VECP _senpar; + + /** + * User given semi-bandwidth of Jacobian (default: -1). + * If a value >= 0 is specified, then it is used instead + * of the automatic detection. + */ + int _jac_sbw; + + /** + * User specification to allow banded solver (default: true). + * Banded solvers are used if _banded is true, _jac_sbw < 0, + * and if the automatic detection indicates that the problem + * can be solved more efficiently in this way. + */ + bool _banded; + bool _banded_solver; // use banded solver or preconditioner + + /** + * User specification if Krylov iterative solver should be used + * instead of direct solver (default: false). + */ + bool _krylov; + + /** + * User specification if a preconditioner should be used + * by the Krylov iterative solver (default: true). + * A banded preconditioner is used if the problem is treated banded. + * Otherwise an incomplete LU factorization is used. + */ + bool _krylov_prec; + + /** + * User defined fixed number of steps. + * (default: 0, i.e. variable step size based on _rtol and _atol) + */ + int _nsteps; + + // vectors and matrices for low level _sys->continuous callback + VECP _cx; + VECP _cu; + VECP _cxp; + VECP _cF; + MATP _cFx; + MATP _cFu; + MATP _cFxp; + // seed derivatives for calculating sensitivity equations + MATP _Xx; + MATP _Xu; + MATP _Xxp; + MATP _Xup; + MATP _Yx; + MATP _Yu; +}; + +#endif + diff --git a/omu/Omu_IntDopri5.C b/omu/Omu_IntDopri5.C new file mode 100644 index 0000000..822dcd0 --- /dev/null +++ b/omu/Omu_IntDopri5.C @@ -0,0 +1,426 @@ +/* + * Omu_IntDopri5.C -- + * -- class implementation + * + * E. Arnold 1999-01-23 C++ version + * continuous output not used! + * 1999-04-23 egcs, g77, libg2c + * 2000-03-29 Real -> double + * error estimation using first _n components only + * _rtol, _atol -> Omu_Integrator + * + */ + +/* + Copyright (C) 1997--1999 Eckhard Arnold + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include + +#include +#include +#include + +#include "Omu_IntDopri5.h" + +IF_CLASS_DEFINE("Dopri5", Omu_IntDopri5, Omu_Integrator); + +//-------------------------------------------------------------------------- + +Omu_IntDopri5::Omu_IntDopri5() +{ + + _y = v_get(1); + k1 = v_get(1); + k2 = v_get(1); + k3 = v_get(1); + k4 = v_get(1); + k5 = v_get(1); + k6 = v_get(1); + y1 = v_get(1); + ysti = v_get(1); + cont = v_get(1); + cont = v_resize(cont, 0); + cont1 = v_get(1); + cont2 = v_get(1); + cont3 = v_get(1); + cont4 = v_get(1); + cont5 = v_get(1); + _icont = px_get(1); + _icont->pe[0] = 0; + _icont = px_resize(_icont, 0); + _u = v_get(1); + + // _rtol = _atol = 1.0e-6; + // _rtol = 1e-6; // see Omu_IntRKsuite.C + // _atol = 1e-12; // + + _nmax = 100000; + _nstiff = 1000; + _hinit = 0.0; + _hmaxinit = 0.0; + _uround = MACHEPS; + _safe = 0.9; + _beta = 0.04; + _fac1 = 0.2; + _fac2 = 10.0; + + // _ifList.append(new If_Float("prg_int_rtol", &_rtol)); + // _ifList.append(new If_Float("prg_int_atol", &_atol)); + _ifList.append(new If_Float("prg_int_hinit", &_hinit)); + _ifList.append(new If_Float("prg_int_hmax", &_hmaxinit)); + // additional interfaces for _nmax, _nstiff, _uround, _safe, _beta, + // _fac1, _fac2, _nfcn, _nstep, _naccpt, _nrejct + +} + +//-------------------------------------------------------------------------- + +Omu_IntDopri5::~Omu_IntDopri5() +{ + + V_FREE(_y); + V_FREE(k1); + V_FREE(k2); + V_FREE(k3); + V_FREE(k4); + V_FREE(k5); + V_FREE(k6); + V_FREE(y1); + V_FREE(ysti); + V_FREE(cont); + V_FREE(cont1); + V_FREE(cont2); + V_FREE(cont3); + V_FREE(cont4); + V_FREE(cont5); + PX_FREE(_icont); + V_FREE(_u); + +} + +//-------------------------------------------------------------------------- + +void Omu_IntDopri5::ode_solve(double tstart, VECP y, const VECP u, double tend) +{ + + int i, res; + + res = 0; + _x = tstart; + _xend = tend; + + // resize _y: without sensitivity analysis _y->dim=_n + if ( _sa ) + v_resize(_y, y->dim); + else + v_resize(_y, _n); + for ( i=0; i<(int)_y->dim; i++ ) + _y[i] = y[i]; + v_resize(_u, u->dim); + _u = v_copy(u, _u); + + // check parameters + if ( _rtol <= 0.0 || _atol <= 0.0 ) { + fprintf(stderr, "Curious input for tolerances rtol = %g, atol = %g\n", + _rtol, _atol); + res = -1; + } + if ( _nmax < 0 ) { + fprintf(stderr, "Wrong input nmax = %ld\n", _nmax); + res = -1; + } + if ( _nstiff < 0 ) + _nstiff = _nmax+10; + if ( _uround <= 1e-35 || _uround >= 1.0 ) { + fprintf(stderr, "Which machine do you have? uround = %g\n", _uround); + res = -1; + } + if ( _safe <= 1e-4 || _safe >= 1.0 ) { + fprintf(stderr, "Curious input for safety factor safe = %g\n", _safe); + res = -1; + } + if ( _beta < 0.0 ) + _beta = 0.0; + else if ( _beta > 0.2 ) { + fprintf(stderr, "Curious input for stabilization parameter beta = %g\n", + _beta); + res = -1; + } + if ( _fac1 < 0.0 || _fac1 > 1.0 || _fac2 < 1.0 ) { + fprintf(stderr, + "Curious input for step size parameters fac1 = %g, fac2 = %g\n", + _fac1, _fac2); + res = -1; + } else { + _facc1 = 1.0/_fac1; + _facc2 = 1.0/_fac2; + } + + // start simulation + _h = fabs(_hinit); + _hmax = fabs(_hmaxinit); + if ( res >= 0 ) + res = simulation(); + if ( res < 0 ) + error(E_UNKNOWN, "Omu_IntDopri5::ode_solve"); + + for ( i=0; i<(int)_y->dim; i++ ) + y[i] = _y[i]; + +} + +//----------------------------------------------------------------------------- + +void Omu_IntDopri5::set_cont(PERM *icont) +{ + + _icont = px_resize(_icont, (int) icont->size); + _icont = px_copy(icont, _icont); + +} + +//----------------------------------------------------------------------------- +// Computation of an initial stepsize guess +double Omu_IntDopri5::hinit() +{ + // Compute a first guess for explicit EULER as + // h = 0.01*norm(y0)/norm(f0) + // the increment for explicit EULER is small compared to the solution + // uses _x, _y, k1, k2, k3, _hmax, _posneg, _atol, _rtol + double sk, dnf, dny, der2, der12, h, h1; + int i; + // for ((dnf=dny=0.0,i=0); i<(int)_y->dim; i++) { + for ( (dnf=dny=0.0,i=0); i<_n; i++ ) { + sk = _atol+_rtol*fabs(_y[i]); + dnf += square(k1[i]/sk); + dny += square(_y[i]/sk); + } + if ( dnf <= 1e-10 || dny <= 1e-10 ) + h = 1e-6; + else + h = sqrt(dny/dnf)*0.01; + h = min(h,_hmax)*_posneg; + // perform an explicit EULER step + for (i=0; i<(int)_y->dim; i++) + k3[i] = _y[i]+h*k1[i]; + f(_x+h, k3, k2); + _nfcn++; + // estimate the 2nd derivative of the solution + // for ((der2=0.0,i=0); i<(int)_y->dim; i++) + for ( (der2=0.0,i=0); i<_n; i++ ) + der2 += square((k2[i]-k1[i])/(_atol+_rtol*fabs(_y[i]))); + der2 = sqrt(der2)/h; + // step-size is computed such that + // h^iord*max(norm(f0),norm(der2)) = 0.01 + der12 = max(fabs(der2),sqrt(dnf)); + if ( der12 <= 1e-15 ) + h1 = max(1e-6,fabs(h)*1e-3); + else + h1 = pow(0.01/der12,1.0/iord); + return min(100*fabs(h),min(h1,_hmax))*_posneg; + +} + +//----------------------------------------------------------------------------- +// Continuous output in connection with output function +VECP Omu_IntDopri5::contd5(const double x, VECP cont) +{ + + int i; + double theta = (x-_xold)/_h, theta1 = 1.0-theta; + for ( i=0; i<(int)_icont->size; i++ ) + cont[i] = cont1[i]+ + theta*(cont2[i]+theta1*(cont3[i]+theta*(cont4[i]+theta1*cont5[i]))); + return cont; + +} + +//----------------------------------------------------------------------------- + +int Omu_IntDopri5::simulation() +{ + + int i, j, last = 0, reject = 0, nonsti = 0, iasti = 0; + double xph, err, facold = 1.0e-4, hlamb = 0.0, expo1, + fac, fac11, h, hnew, stnum, stden; + char format979[100] = " Exit of DOPRI at x = %g, "; + + // ensure that k1, ..., k6, ysti are of the correct size + v_resize(k1, _y->dim); + v_resize(k2, _y->dim); + v_resize(k3, _y->dim); + v_resize(k4, _y->dim); + v_resize(k5, _y->dim); + v_resize(k6, _y->dim); + v_resize(y1, _y->dim); + v_resize(ysti, _y->dim); + + // ensure that cont1, ..., cont are of the correct size + v_resize(cont1, _icont->size); + v_resize(cont2, _icont->size); + v_resize(cont3, _icont->size); + v_resize(cont4, _icont->size); + v_resize(cont5, _icont->size); + + _nfcn = _nstep = _naccpt = _nrejct = 0; + expo1 = 0.2-0.04*0.75; + + h = _h; + if ( _hmax == 0.0 ) + _hmax = fabs(_xend-_x); + if ( (_xend > _x && h <= 0) || (_xend < _x && h > 0.0) ) + _h = h = -h; + + _posneg = (_xend-_x)/fabs(_xend-_x); + + f(_x, _y, k1); + _nfcn++; + if (h == 0.0) + _h = h = hinit(); + _xold = _x; + + for ( j=0; j<(int)_icont->size; j++ ) + cont[j] = _y[_icont->pe[j]]; + if ( fout(_naccpt+1, _x, cont) ) { + fprintf(stderr, format979, _x); + return 2; + } + + // basic integration step + while ( ! last ) { + if ( _nstep > _nmax ) { + fprintf(stderr, + strcat(format979,"more than nmax = %d steps are needed.\n"), + _x, _nmax); + return -2; + } + if ( 0.1*fabs(h) <= _uround*fabs(_x) ) { + fprintf(stderr, strcat(format979,"stepsize to small, h = %g\n"), _x, h); + return -3; + } + last = ((_x+1.01*h-_xend)*_posneg > 0.0); + if ( last ) + _h = h = _xend-_x; + _nstep++; + + // the first 6 stages + for ( i=0; i<(int)_y->dim; i++ ) + y1[i] = _y[i]+h*a21*k1[i]; + f(_x+c2*h, y1, k2); + for ( i=0; i<(int)_y->dim; i++ ) + y1[i] = _y[i]+h*(a31*k1[i]+a32*k2[i]); + f(_x+c3*h, y1, k3); + for ( i=0; i<(int)_y->dim; i++ ) + y1[i] = _y[i]+h*(a41*k1[i]+a42*k2[i]+a43*k3[i]); + f(_x+c4*h, y1, k4); + for ( i=0; i<(int)_y->dim; i++ ) + y1[i] = _y[i]+h*(a51*k1[i]+a52*k2[i]+a53*k3[i]+a54*k4[i]); + f(_x+c5*h, y1, k5); + for ( i=0; i<(int)_y->dim; i++ ) + ysti[i] = _y[i]+h*(a61*k1[i]+a62*k2[i]+a63*k3[i]+a64*k4[i]+a65*k5[i]); + xph = _x+h; + f(xph, ysti, k6); + for ( i=0; i<(int)_y->dim; i++ ) + y1[i] = _y[i]+h*(a71*k1[i]+a73*k3[i]+a74*k4[i]+a75*k5[i]+a76*k6[i]); + f(xph, y1, k2); + _nfcn += 6; + + for ( j=0; j<(int)_icont->size; j++ ) { + i = _icont->pe[j]; + cont5[i] = h*(d1*k1[i]+d3*k3[i]+d4*k4[i]+d5*k5[i]+d6*k6[i]+d7*k2[i]); + } + for ( i=0; i<(int)_y->dim; i++ ) + k4[i] = h*(e1*k1[i]+e3*k3[i]+e4*k4[i]+e5*k5[i]+e6*k6[i]+e7*k2[i]); + + // error estimation + for ( (err=0.0,i=0); i<(!_serr?_n:(int)_y->dim); i++ ) + err += square(k4[i]/(_atol+_rtol*max(fabs(_y[i]),fabs(y1[i])))); + err = sqrt(err/(!_serr?_n:(int)_y->dim)); + + // computation of hnew + fac11 = pow(err,expo1); + // LUND stabilization + fac = fac11/pow(facold,_beta); + // we require fac1 <= hnew/h <= fac2 + fac = max(_facc2,min(_facc1,fac/_safe)); + hnew = h/fac; + + if ( err<=1.0 ) { // step is accepted + facold = max(err,1e-4); + _naccpt++; + // stiffness detection + if ( (_naccpt % _nstiff) == 0 || iasti > 0 ) { + for ( (stnum=stden=0.0, i=0); i<(!_serr?_n:(int)_y->dim); i++ ) { + stnum += square(k2[i]-k6[i]); + stden += square(y1[i]-ysti[i]); + } + if ( stden > 0.0 ) + hlamb = h*sqrt(stnum/stden); + if ( hlamb > 3.25 ) { + nonsti = 0; + iasti++; + if (iasti == 15) { + fprintf(stderr, + "The problem seems to become stiff at x = %g\n", _x); + return -4; + } + } else { + nonsti++; + if ( nonsti == 6 ) + iasti = 0; + } + } + for ( j=0; j<(int)_icont->size; j++ ) { + i = _icont->pe[j]; + cont1[i] = _y[i]; + cont2[i] = y1[i]-_y[i]; + cont3[i] = h*k1[i]-cont2[i]; + cont4[i] = -h*k2[i]+cont2[i]-cont3[i]; + } + v_copy(k2, k1); + v_copy(y1, _y); + _xold = _x; + _x = xph; + if ( fout(_naccpt+1, _x, cont) ) { + fprintf(stderr, format979, _x); + return 2; + } + if ( last ) { + _h = h = hnew; + return 1; + } + if ( fabs(hnew) > _hmax ) + hnew = _posneg*_hmax; + if ( reject ) + hnew = _posneg*min(fabs(hnew),fabs(h)); + reject = 0; + } else { // step is rejected + hnew = h/min(_facc1,fac11/_safe); + reject = 1; + if ( _naccpt >= 1 ) + _nrejct++; + last = 0; + } + _h = h = hnew; + } + return 1; + +} + +//============================================================================= diff --git a/omu/Omu_IntDopri5.h b/omu/Omu_IntDopri5.h new file mode 100644 index 0000000..d2a8120 --- /dev/null +++ b/omu/Omu_IntDopri5.h @@ -0,0 +1,117 @@ +/* + * Omu_IntDopri5.h -- + * -- integrate ODE over a stage using Dormand-Prince + * + * Reference: FORTRAN code dopri5.f: + * + * NUMERICAL SOLUTION OF A SYSTEM OF FIRST 0RDER + * ORDINARY DIFFERENTIAL EQUATIONS Y'=F(X,Y). + * THIS IS AN EXPLICIT RUNGE-KUTTA METHOD OF ORDER (4)5 + * DUE TO DORMAND & PRINCE (WITH STEPSIZE CONTROL AND + * DENSE OUTPUT). + * + * AUTHORS: E. HAIRER AND G. WANNER + * UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES + * CH-1211 GENEVE 24, SWITZERLAND + * E-MAIL: HAIRER@UNI2A.UNIGE.CH, WANNER@UNI2A.UNIGE.CH + * + * THIS CODE IS DESCRIBED IN: + * E. HAIRER, S.P. NORSETT AND G. WANNER, SOLVING ORDINARY + * DIFFERENTIAL EQUATIONS I. NONSTIFF PROBLEMS. 2ND EDITION. + * SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, + * SPRINGER-VERLAG (1993) + * + * VERSION OF MARCH 24, 1993 + * + * + * E. Arnold 1999-01-23 C++ version + * continuous output not used! + * 1999-04-23 egcs, g77, libg2c * + * 2000-03-29 Real -> double + * error estimation using first _n components only + * _rtol, _atol -> Omu_Integrator + * + */ + +/* + Copyright (C) 1997--2000 Eckhard Arnold + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Omu_IntDopri5_H +#define Omu_IntDopri5_H + +#include "Omu_IntODE.h" + +//-------------------------------------------------------------------------- +class Omu_IntDopri5: public Omu_IntODE { + + public: + + Omu_IntDopri5(); + ~Omu_IntDopri5(); + + char *name() {return "Dopri5";} + + // interface routine + void ode_solve(double tstart, VECP y, const VECP u, double tend); + + private: + + /* RUNGE-KUTTA coefficients of DORMAND and PRINCE (1980) */ + static const double c2 = 0.2, c3 = 0.3, c4 = 0.8, c5 = 8.0/9.0, + a21 = 0.2, a31 = 3.0/40.0, a32 = 9.0/40.0, + a41 = 44.0/45.0, a42 = -56.0/15.0, a43 = 32.0/9.0, + a51 = 19372.0/6561.0, a52 = -25360.0/2187.0, a53 = 64448.0/6561.0, + a54 = -212.0/729.0, a61 = 9017.0/3168.0, a62 = -355.0/33.0, + a63 = 46732.0/5247.0, a64 = 49.0/176.0, a65 = -5103.0/18656.0, + a71 = 35.0/384.0, a73 = 500.0/1113.0, a74 = 125.0/192.0, + a75 = -2187.0/6784.0, a76 = 11.0/84.0, e1 = 71.0/57600.0, + e3 = -71.0/16695.0, e4 = 71.0/1920.0, e5 = -17253.0/339200.0, + e6 = 22.0/525.0, e7 = -1.0/40.0, + /* dense output of SHAMPINE (1986) */ + d1 = -12715105075.0/11282082432.0, + d3 = 87487479700.0/32700410799.0, + d4 = -10690763975.0/1880347072.0, + d5 = 701980252875.0/199316789632.0, + d6 = -1453857185.0/822651844.0, + d7 = 69997945.0/29380423.0; + static const int iord = 5; + + VECP _y, k1, k2, k3, k4, k5, k6, y1, ysti; + VECP cont, cont1, cont2, cont3, cont4, cont5; + VECP _u; + PERM *_icont; + + double _uround, _safe, _beta, _fac1, _fac2, _facc1, _facc2; + long int _nmax, _nstiff, _nfcn, _nstep, _naccpt, _nrejct; + + double _xold, _posneg, _h, _x, _xend, _hmax; + /* double _rtol, _atol; */ + double _hinit, _hmaxinit; + + public: + VECP contd5(const double x, VECP cont); + void f(const double x, const VECP y, VECP dy) { syseq(x, y, _u, dy); }; + int fout(const int nr, const double x, VECP y) { return 0;} + void set_cont(PERM *icont); + void set_initstep(double h, double hmax = 0.0); + double hinit(); + int simulation(); +}; + +#endif diff --git a/omu/Omu_IntEuler.C b/omu/Omu_IntEuler.C new file mode 100644 index 0000000..c7566f6 --- /dev/null +++ b/omu/Omu_IntEuler.C @@ -0,0 +1,75 @@ +/* + * Omu_IntEuler.C -- + * -- class implementation + * + * rf, 10/2/96 + */ + +/* + Copyright (C) 1997--2001 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include + +#include + +#include +#include +#include + +#include "Omu_IntEuler.h" + +IF_CLASS_DEFINE("Euler", Omu_IntEuler, Omu_Integrator); + +//-------------------------------------------------------------------------- +Omu_IntEuler::Omu_IntEuler() +{ + _f = v_get(1); +} + +//-------------------------------------------------------------------------- +Omu_IntEuler::~Omu_IntEuler() +{ + v_free(_f); +} + +//-------------------------------------------------------------------------- +void Omu_IntEuler::ode_solve(Real tstart, VECP y, const VECP u, Real tend) +{ + Real dt; + int i, nsteps; + int neq = y->dim; + + v_resize(_f, neq); + + // obtain number of steps + if (_stepsize > 0.0) + nsteps = (int)ceil((tend - tstart) / _stepsize); + else + nsteps = 1; + dt = (tend - tstart) / nsteps; + + // apply Euler's integration rule + for (i = 0; i < nsteps; ++i) { + syseq(tstart + i*dt, y, u, _f); + v_mltadd(y, _f, dt, y); + } +} + + +//======================================================================== diff --git a/omu/Omu_IntEuler.h b/omu/Omu_IntEuler.h new file mode 100644 index 0000000..2f6abd1 --- /dev/null +++ b/omu/Omu_IntEuler.h @@ -0,0 +1,52 @@ +/* + * Omu_IntEuler.h -- + * -- integrate ODE over a stage using fixed step size Euler rule + * + * rf, 02/07/01 + * + */ + +/* + Copyright (C) 1997--2001 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Omu_IntEuler_H +#define Omu_IntEuler_H + +#include "Omu_IntODE.h" + +//-------------------------------------------------------------------------- +class Omu_IntEuler: public Omu_IntODE { + + public: + + Omu_IntEuler(); + ~Omu_IntEuler(); + + char *name() {return "Euler";} + + // interface routine + void ode_solve(Real tstart, VECP y, const VECP u, Real tend); + + private: + + VECP _f; +}; + +#endif + diff --git a/omu/Omu_IntIMP.C b/omu/Omu_IntIMP.C new file mode 100644 index 0000000..276dc02 --- /dev/null +++ b/omu/Omu_IntIMP.C @@ -0,0 +1,345 @@ +/* + * Omu_IntIMP.C -- + * -- class implementation + * + * E. Arnold 1999-04-12 + * 2000-05-30 step size control + * + */ + +/* + Copyright (C) 1999--2000 Eckhard Arnold + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include + +#include +#include +#include + +#include "Omu_IntIMP.h" + +extern "C" { +#include +} + +IF_CLASS_DEFINE("IMP", Omu_IntIMP, Omu_Integrator); + +//-------------------------------------------------------------------------- +Omu_IntIMP::Omu_IntIMP() +{ + + _y = v_get(1); + _u = v_get(1); + _k1 = v_get(1); + _y0 = v_get(1); + _res = v_get(1); + _fh = v_get(1); + _yjac = v_get(1); + _yjacp = v_get(1); + _yy = m_get(1, 1); + _yyn = m_get(1, 1); + _ppivot= px_get(1); + _y1 = v_get(1); + _y2 = v_get(1); + + _nsteps = 0; + _modnewtonsteps = 5; + _maxiters = 20; + _hinit = 0.0; + _dt = 0.0; + _IMP = 1; + + _ifList.append(new If_Int("prg_int_nsteps", &_nsteps)); + _ifList.append(new If_Int("prg_int_modnewtonsteps", &_modnewtonsteps)); + _ifList.append(new If_Int("prg_int_maxiters", &_maxiters)); + _ifList.append(new If_Float("prg_int_hinit", &_hinit)); + + _res_evals = 0; + _jac_evals = 0; + +} + +//-------------------------------------------------------------------------- +Omu_IntIMP::~Omu_IntIMP() +{ + + V_FREE(_y); + V_FREE(_u); + V_FREE(_k1); + V_FREE(_y0); + V_FREE(_res); + V_FREE(_fh); + V_FREE(_yjac); + V_FREE(_yjacp); + M_FREE(_yy); + M_FREE(_yyn); + PX_FREE(_ppivot); + V_FREE(_y1); + V_FREE(_y2); + +} + +//-------------------------------------------------------------------------- +void Omu_IntIMP::realloc() +{ + + v_resize(_u, _npar); + v_resize(_y, _n); + v_resize(_y0, _n); + v_resize(_k1, _n); + v_resize(_res, _n); + v_resize(_fh, _n); + + v_resize(_yjac, _n*(1+_n+_npar)); + v_resize(_yjacp, _n*(1+_n+_npar)); + m_resize(_yy, _n, _n); + px_resize(_ppivot, _n); + + if ( _sa ) { + v_resize(_y1, _n*(1+_n+_npar)); + v_resize(_y2, _n*(1+_n+_npar)); + } else { + v_resize(_y1, _n); + v_resize(_y2, _n); + } + +} + +//-------------------------------------------------------------------------- +void eigenvalue(MATP A) +{ + + MATP S, Q; + VECP E_re, E_im; + int i, imin, imax; + + S = m_get(A->m, A->m); + m_copy(A, S); + Q = m_get(A->m, A->m); + schur(S, Q); + E_re = v_get(A->m); + E_im = v_get(A->m); + schur_evals(S, E_re, E_im); + imin = imax = 0; + for ( i = 1; i < (int) A->m; i++ ) { + if ( E_re[i] < E_re[imin] ) + imin = i; + if ( E_re[i] > E_re[imax] ) + imax = i; + } + printf("l-min: %g+/-%g*j, l-max: %g+/-%g*j\n", + E_re[imin], E_im[imin], E_re[imax], E_im[imax]); + V_FREE(E_re); + V_FREE(E_im); + M_FREE(Q); + M_FREE(S); + +} + +//-------------------------------------------------------------------------- +void Omu_IntIMP::jac(double t, VECP y) +{ + + bool sa_old; + int i, j; + + v_zero(_yjac); + v_zero(_yjacp); + + for ( i = 0; i < _n; i++ ) { + _yjac[i] = y[i]; + _yjac[(1+_nd+i)*_n+i] = 1.0; + } + + sa_old = _sa; + _sa = 1; + syseq(t, _yjac, _u, _yjacp); + _sa = sa_old; + + for ( i = 0; i < _n; i++ ) + for ( j = 0; j < _n; j++ ) + _yy[i][j] = _yjacp[(1+_nd+j)*_n+i]; + + _jac_evals++; + + // eigenvalue(_yy); + +} + +//-------------------------------------------------------------------------- +// _IMP==0: BW Euler +// _IMP==1: IMP +void Omu_IntIMP::step(double tstep, double dt, VECP y) +{ + bool ok, sa_old = _sa; + int i, j, inewton; + double t, cmeth; + + // IMP or BW Euler? + cmeth = _IMP==1 ? 2.0 : 1.0; + + _sa = 0; + for ( i = 0; i < _n; i++ ) + _y0[i] = y[i]; + v_zero(_k1); + v_zero(_fh); + t = tstep+dt/cmeth; + + // modified Newton's method + for ( inewton = 0; inewton < _maxiters; inewton++ ) { + v_mltadd(_y0, _k1, dt/cmeth, _y); + syseq(t, _y, _u, _fh); + v_sub(_k1, _fh, _res); + + // check for convergence + for ( ok = true, i = 0 ; i < _n; i++ ) + ok = ok && ( fabs(_res[i])<0.1*(_atol+fabs(_k1[i])) ); + if ( ok ) + break; + else if ( inewton == _maxiters-1 ) + error(E_INTERN, + "Omu_IntIMP::ode_solve Newton method failed to converge"); + + // (re)calculate and factorize Jacobian + if ( !(inewton % _modnewtonsteps) ) { + jac(t, _y); + sm_mlt(-dt/cmeth, _yy, _yyn); + for ( i = 0; i < _n; i++ ) + _yyn[i][i] += 1.0; + LUfactor(_yyn, _ppivot); + } + + LUsolve(_yyn, _ppivot, _res, _fh); + v_sub(_k1, _fh, _k1); + } + + // calculate step + v_mltadd(_y0, _k1, dt, _y); + for ( i = 0; i < _n; i++ ) + y[i] = _y[i]; + + // sensitivities + if ( sa_old ) { + v_mltadd(_y0, _k1, dt/cmeth, _y); + + // (re)calculate and factorize Jacobian + jac(t, _y); + sm_mlt(-dt/cmeth, _yy, _yyn); + for ( i = 0; i < _n; i++ ) + _yyn[i][i] += 1.0; + LUfactor(_yyn, _ppivot); + + sm_mlt(dt/cmeth, _yy, _yy); + for ( i = 0; i < _n; i++ ) + _yy[i][i] += 1.0; + + for ( i = 0; i < _n+_npar; i++ ) { + for ( j = 0; j < _n; j++ ) + _res[j] = y[_n*(1+i)+j]; + mv_mlt(_yy, _res, _fh); + if ( i >= _n ) + for ( j = 0; j < _n; j++ ) + _fh[j] += dt*_yjacp[_n*(1+i)+j]; + + LUsolve(_yyn, _ppivot, _fh, _fh); + for ( j = 0; j < _n; j++ ) + y[_n*(1+i)+j] = _fh[j]; + } + } + + _sa = sa_old; +} + +//-------------------------------------------------------------------------- +void Omu_IntIMP::ode_solve(double tstart, VECP y, const VECP u, double tend) +{ + + double t, dt, err, tol, ynorm, dtnew; + int i, istep; + + _npar = u->dim; + realloc(); + v_copy(u, _u); + + // _stepsize overrides _nsteps + int nsteps = _nsteps; + if (_stepsize > 0.0) + nsteps = (int)ceil((tend - tstart) / _stepsize); + + if ( nsteps > 0 ) { + // with fixed step size + dt = (tend - tstart)/nsteps; + for ( istep = 0; istep < nsteps; istep++) + step(tstart+istep*dt, dt, y); + } else { + // with step size control + if ( _hinit > 0.0 ) + dt = _hinit; + else + dt = _dt; + if ( dt == 0.0 ) + dt = (tend-tstart)/10.0; + + t = tstart; + while ( t < tend ) { + _dt = dt; + if ( dt < 10.0*MACHEPS*t ) + error(E_INTERN, + "Omu_IntIMP::ode_solve step size too small"); + if ( t+dt > tend ) + dt = tend-t; + + // BW Euler step + for ( i = 0; i < (int) _y1->dim; i++ ) + _y1[i] = y[i]; + _IMP = 0; + step(t, dt, _y1); + + // IMP step + for ( i = 0; i < (int) _y2->dim; i++ ) + _y2[i] = y[i]; + _IMP = 1; + step(t, dt, _y2); + + // local error estimation + for ( i = 0, err = 0.0, ynorm = 0.0; i < _n; i++ ) { + err += square(_y1[i]-_y2[i]); + ynorm += square(_y2[i]); + } + err = sqrt(err); + ynorm = sqrt(ynorm); + tol = _atol+_rtol*ynorm; + dtnew = 0.9*dt*sqrt(tol/(MACHEPS+err)); + + if ( err > tol ) { + // reject step + dt = max(0.25*dt, dtnew); + } else { + // accept step + for ( i = 0; i < (int) _y2->dim; i++ ) + y[i] = _y2[i]; + t += dt; + dt = max(dt, min(dtnew, 4.0*dt)); + } + } + } + +} + +//======================================================================== diff --git a/omu/Omu_IntIMP.h b/omu/Omu_IntIMP.h new file mode 100644 index 0000000..2a8bcfe --- /dev/null +++ b/omu/Omu_IntIMP.h @@ -0,0 +1,79 @@ +/* + * Omu_IntIMP.h -- + * -- integrate an ODE over a stage using the implicit midpoint rule + * + * E. Arnold 1999-04-12 + * 2000-05-12 _rtol, _atol -> Omu_Integrator + * 2000-05-30 step size control + * + */ + +/* + Copyright (C) 1999--2000 Eckhard Arnold + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Omu_IntIMP_H +#define Omu_IntIMP_H + +#include "Omu_IntODE.h" + +//-------------------------------------------------------------------------- +class Omu_IntIMP: public Omu_IntODE { + + public: + + Omu_IntIMP(); + ~Omu_IntIMP(); + + char *name() {return "IMP";} + + // interface routine + void ode_solve(double tstart, VECP y, const VECP u, double tend); + + private: + + void realloc(); + void jac(double t, VECP y); + void step(double tstep, double dt, VECP y); + + VECP _y; + VECP _u; + VECP _k1; + VECP _y0; + VECP _res; + VECP _fh; + VECP _yjac; + VECP _yjacp; + MATP _yy; + MATP _yyn; + PERM *_ppivot; + VECP _y1; + VECP _y2; + + int _npar; + int _nsteps; + int _modnewtonsteps; + int _maxiters; + double _hinit; + double _dt; + int _IMP; + +}; + +#endif + diff --git a/omu/Omu_IntODE.C b/omu/Omu_IntODE.C new file mode 100644 index 0000000..45dccc8 --- /dev/null +++ b/omu/Omu_IntODE.C @@ -0,0 +1,355 @@ +/* + * Omu_IntODE.C -- + * -- class implementation + * + * rf, 10/2/96 + */ + +/* + Copyright (C) 1997--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include + +#include + +#include + +#include "Omu_IntODE.h" + +//-------------------------------------------------------------------------- +Omu_IntODE::Omu_IntODE() +{ + _y = v_get(1); + _u = v_get(1); + _D = VNULL; + + _x = v_get(1); + _v = v_get(1); + _X = m_get(1, 1); + _Y = m_get(1, 1); + + _cx = v_get(1); + _cu = v_get(1); + _cxp = v_get(1); + _cF = v_get(1); + _cFx = m_get(1, 1); + _cFu = m_get(1, 1); + _Xx = m_get(1, 1); + _Xu = m_get(1, 1); + _Yx = m_get(1, 1); + _Yu = m_get(1, 1); +} + +//-------------------------------------------------------------------------- +Omu_IntODE::~Omu_IntODE() +{ + m_free(_Y); + m_free(_X); + v_free(_v); + v_free(_x); + + v_free(_D); + v_free(_u); + v_free(_y); + + v_free(_cx); + v_free(_cu); + v_free(_cxp); + v_free(_cF); + m_free(_cFx); + m_free(_cFu); + m_free(_Xx); + m_free(_Xu); + m_free(_Yx); + m_free(_Yu); +} + +//-------------------------------------------------------------------------- +void Omu_IntODE::init_stage(int k, + const Omu_States &x, const Omu_Vector &u, + bool sa) +{ + if (!x.D_is_const) { + error(E_FORMAT, + "Omu_IntODE::init_stage, which was called for non const dF/dxp"); + } + if (x.na > 0) { + error(E_FORMAT, + "Omu_IntODE::init_stage, which was called for algebraic states"); + } + Omu_Integrator::init_stage(k, x, u, sa); + realloc(); +} + +//-------------------------------------------------------------------------- +void Omu_IntODE::realloc() +{ + if (_cx->dim == _nxt && _cu->dim == _nu) + return; + + int neq = _n * (1 + _nx + _nu); + v_resize(_y, neq); + v_resize(_u, _nd + _nu); + + // + // variables for ADOL-C + // + + v_resize(_x, _nd + 2 * _n + _nu); + v_resize(_v, _nd + 2 * _n + _nu); + m_resize(_X, _nd + 2 * _n + _nu, _nx + _nu); + m_resize(_Y, _n, _nx + _nu); + + // + // variables for low level _sys->continuous callback + // + v_resize(_cx, _nd + _n); + v_resize(_cu, _nu); + v_resize(_cxp, _nd + _n); + v_resize(_cF, _nd + _n); + m_resize(_cFx, _nd + _n, _nd + _n); + m_resize(_cFu, _nd + _n, _nu); + m_resize(_Xx, _nd + _n, _nx); + m_resize(_Xu, _nd + _n, _nu); + m_resize(_Yx, _nd + _n, _nx); + m_resize(_Yu, _nd + _n, _nu); +} + +//-------------------------------------------------------------------------- +void Omu_IntODE::solve(int kk, Real tstart, Real tend, + const Omu_States &x, const Omu_Vector &u, + Omu_Program *sys, VECP xt, + MATP Sx, MATP Su) +{ + int i, j; + + _sys = sys; // propagate to syseq() + + _D = v_resize(_D, _nxt - _nd); + for (i = _nd; i < _nxt; i++) + _D[i - _nd] = -1.0 / x.D[i]; + + v_zero(_y); + + for (i = 0; i < _nd; i++) { + _u[i] = xt[i]; + } + for (i = 0; i < _n; i++) { + _y[i] = xt[_nd + i]; // initial states + } + for (i = 0; i < _nu; i++) { + _u[_nd + i] = u[i]; + } + + if (_sa) { + for (i = 0; i < _n; i++) { + for (j = 0; j < _nx; j++) { + _y[(1 + j) * _n + i] = Sx[_nd + i][j]; + } + for (j = 0; j < _nu; j++) { + _y[(1 + _nx + j) * _n + i] = Su[_nd + i][j]; + } + } + } + + _kk = kk; // propagate to syseq() + + ode_solve(tstart, _y, _u, tend); + + for (i = 0; i < _n; i++) { + xt[_nd + i] = _y[i]; + } + + if (_sa) { + for (i = 0; i < _n; i++) { + for (j = 0; j < _nx; j++) { + Sx[_nd + i][j] = _y[(1 + j) * _n + i]; + } + for (j = 0; j < _nu; j++) { + Su[_nd + i][j] = _y[(1 + _nx + j) * _n + i]; + } + } + } +} + +// default implementation calling low-level _sys->continuous() +//-------------------------------------------------------------------------- +void Omu_IntODE::syseq(Real t, const VECP y, const VECP u, + VECP f) +{ + if (!_sys->has_low_level_continuous()) { + // call faster version if no user defined low-level continuous + syseq_forward(t, y, u, f); + return; + } + + int i, j; + + // + // form a vector of independent variables + // + + for (i = 0; i < _nd; i++) { + _cx[i] = u[i]; + } + for (i = 0; i < _n; i++) { + _cx[_nd + i] = y[i]; + } + for (i = 0; i < _nu; i++) { + _cu[i] = u[_nd + i]; + } + v_zero(_cxp); + + // + // evaluate residual + // + + if (_sa) { + m_zero(_cFx); + m_zero(_cFu); + _sys->continuous(_kk, t, _cx, _cu, _cxp, _cF, _cFx, _cFu); + // don't pass _cFxp so that it is not calculated for ODEs + } + else + _sys->continuous(_kk, t, _cx, _cu, _cxp, _cF); + + for (i = 0; i < _n; i++) { + f[i] = _cF[_nd + i] * _D[i]; + } + + if (_sa) { + m_zero(_Xx); + m_zero(_Xu); + for (i = 0; i < _nd; i++) { + _Xx[i][i] = 1.0; + } + for (i = 0; i < _n; i++) { + for (j = 0; j < _nx; j++) { + _Xx[_nd + i][j] = y[(1 + j) * _n + i]; + } + for (j = 0; j < _nu; j++) { + _Xu[_nd + i][j] = y[(1 + _nx + j) * _n + i]; + } + } + m_mlt(_cFx, _Xx, _Yx); + m_mlt(_cFx, _Xu, _Yu); + m_add(_cFu, _Yu, _Yu); + + for (i = 0; i < _n; i++) { + for (j = 0; j < _nx; j++) { + f[(1 + j) * _n + i] = _Yx[_nd + i][j] * _D[i]; + } + for (j = 0; j < _nu; j++) { + f[(1 + _nx + j) * _n + i] = _Yu[_nd + i][j] * _D[i]; + } + } + } + + _res_evals++; + if (_sa) + _sen_evals++; +} + +// alternative implementation calling high-level _sys->continuous +//-------------------------------------------------------------------------- +void Omu_IntODE::syseq_forward(Real t, const VECP y, const VECP u, + VECP f) +{ + int i, j; + + // + // form a vector of independent variables + // + + for (i = 0; i < _nd; i++) { + _x[i] = u[i]; + } + for (i = 0; i < _n; i++) { + _x[_nd + i] = y[i]; + _x[_nd + _n + i] = 0.0; // yprime[i] + } + for (i = 0; i < _nu; i++) { + _x[_nd + 2 * _n + i] = u[_nd + i]; + } + + // + // evaluate residual + // + + adoublev ax(_nd + _n); + adoublev axp(_nd + _n); + adoublev au(_nu); + adoublev aF(_nd + _n); + + for (i = 0; i < _nd; i++) + axp[i] = 0.0; + for (i = _nd; i < _nxt; i++) + aF[i] = 0.0; + + if (_sa) + trace_on(3); // tape 3 + ax <<= _x->ve; + for (i = 0; i < _n; i++) + axp[_nd + i] <<= _x->ve[_nd + _n + i]; + au <<= _x->ve + _nd + 2 * _n; + + _sys->continuous(_kk, t, ax, au, axp, aF); + + for (i = 0; i < _n; i++) { + aF[_nd + i] >>= f[i]; + f[i] *= _D[i]; + } + + if (_sa) { + trace_off(); + + int nindep = _nd + 2 * _n + _nu; + int npar = _nx + _nu; + + m_zero(_X); + for (i = 0; i < _nd; i++) { + _X[i][i] = 1.0; + } + for (i = 0; i < _n; i++) { + for (j = 0; j < npar; j++) { + _X[_nd + i][j] = y[(1 + j) * _n + i]; + _X[_nd + _n + i][j] = 0.0; // yprime[(1 + j) * _n + i]; + } + } + for (i = 0; i < _nu; i++) { + _X[_nd + 2 * _n + i][_nd + _n + i] = 1.0; + } + + forward(3, _n, nindep, npar, _x->ve, _X->me, f->ve, _Y->me); + + for (i = 0; i < _n; i++) { + f[i] *= _D[i]; + for (j = 0; j < npar; j++) { + f[(1 + j) * _n + i] = _Y[i][j] * _D[i]; + } + } + } + + _res_evals++; + if (_sa) + _sen_evals++; +} + + +//======================================================================== diff --git a/omu/Omu_IntODE.h b/omu/Omu_IntODE.h new file mode 100644 index 0000000..7704220 --- /dev/null +++ b/omu/Omu_IntODE.h @@ -0,0 +1,92 @@ +/* + * Omu_IntODE.h -- + * -- base class for integrating an ODE over a stage + * -- derived classes add a specific integration rule + * + * rf, 11/13/96 + */ + +/* + Copyright (C) 1997--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Omu_IntODE_H +#define Omu_IntODE_H + +#include "Omu_Integrator.h" + +//-------------------------------------------------------------------------- +class Omu_IntODE: public Omu_Integrator { + + public: + + Omu_IntODE(); + ~Omu_IntODE(); + + // interface routine from Omu_Integrator + void init_stage(int k, + const Omu_States &x, const Omu_Vector &u, + bool sa = false); + void solve(int kk, Real tstart, Real tend, + const Omu_States &x, const Omu_Vector &u, + Omu_Program *sys, VECP xt, + MATP Sx, MATP Su); + + // routines provided by derived classes + virtual void ode_solve(Real tstart, VECP y, VECP u, Real tend) = 0; + + // routines to be called by derived classes + void syseq(Real t, const VECP y, const VECP u, VECP f); + + private: + + /** + * alternative syseq implementation calling high-level + * continuous and using forward for derivatives + */ + void syseq_forward(Real t, const VECP y, const VECP u, VECP f); + + // backing store sys and current stage + Omu_Program *_sys; + + VECP _y; + VECP _u; + VECP _D; // -(dF/dy')^(-1) + + void realloc(); + + // variables for ADOL-C + VECP _x; + VECP _v; + MATP _X; + MATP _Y; + + // vectors and matrices for low level _sys->continuous callback + VECP _cx; + VECP _cu; + VECP _cxp; + VECP _cF; + MATP _cFx; + MATP _cFu; + MATP _Xx; + MATP _Xu; + MATP _Yx; + MATP _Yu; +}; + +#endif diff --git a/omu/Omu_IntOdeTs.C b/omu/Omu_IntOdeTs.C new file mode 100644 index 0000000..91d3198 --- /dev/null +++ b/omu/Omu_IntOdeTs.C @@ -0,0 +1,590 @@ +/* + * Omu_IntOdeTs.C -- + * -- class for integrating an Ode over a stage + * -- using Taylor series + * + * hl, 28/01/98 + */ + +/* + Copyright (C) 1997--1999 Hartmut Linke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include + +#include + +#include +#include +#include +#include +#include + +#include "Omu_IntOdeTs.h" + +IF_CLASS_DEFINE("OdeTs", Omu_IntOdeTs, Omu_Integrator); + +#define mindec(a,b) if ((a) > (b)) (a) = (b) + +//-------------------------------------------------------------------------- + +Omu_IntOdeTs::Omu_IntOdeTs() +{ + + int i; + + _adtaylor = false; + _multiple_record = true; + _output = 0; + + _max_deg = 31; + _max_deg0 = 30; + + _n = 0; + _m = 0; + _kk = 0; + + _tau = 1.0; + _rho = 0.0; + +// _atol = 1.0e-6; +// _rtol = 1.0e-3; + + _a = v_resize(v_get(1),0); + _u = v_resize(v_get(1),0); + _x = v_resize(v_get(1),0); + + _Sxd = m_resize(m_get(1,1),0,0); + _Sxd0 = m_resize(m_get(1,1),0,0); + _Sxx = m_resize(m_get(1,1),0,0); + _Sxx0 = m_resize(m_get(1,1),0,0); + _Sxu = m_resize(m_get(1,1),0,0); + _Sxu0 = m_resize(m_get(1,1),0,0); + _Sh = m_resize(m_get(1,1),0,0); + + _nz = NULL; + +// _ifList.append(new If_Float("prg_int_atol", &_atol)); +// _ifList.append(new If_Float("prg_int_rtol", &_rtol)); + _ifList.append(new If_Float("prg_int_rho", &_rho)); + _ifList.append(new If_Float("prg_int_tau", &_tau)); + _ifList.append(new If_Int("prg_int_maxdeg", &_max_deg0)); + _ifList.append(new If_Int("prg_int_out", &_output)); + _ifList.append(new If_Bool("prg_int_multrec", &_multiple_record)); + +} + +//-------------------------------------------------------------------------- + +Omu_IntOdeTs::Omu_IntOdeTs(int max_deg) +{ + + int i; + + _adtaylor = false; + _multiple_record = true; + _output = 0; + + _max_deg = max_deg+1; + _max_deg0 = max_deg; + + _n = 0; + _m = 0; + _kk = 0; + + _tau = 1.0; + _rho = 0.0; + +// _atol = 1.0e-3; +// _rtol = 1.0e-6; + + _a = v_resize(v_get(1),0); + _u = v_resize(v_get(1),0); + _x = v_resize(v_get(1),0); + + _Sxd = m_resize(m_get(1,1),0,0); + _Sxd0 = m_resize(m_get(1,1),0,0); + _Sxx = m_resize(m_get(1,1),0,0); + _Sxx0 = m_resize(m_get(1,1),0,0); + _Sxu = m_resize(m_get(1,1),0,0); + _Sxu0 = m_resize(m_get(1,1),0,0); + _Sh = m_resize(m_get(1,1),0,0); + + _nz = NULL; + +// _ifList.append(new If_Float("prg_int_atol", &_atol)); +// _ifList.append(new If_Float("prg_int_rtol", &_rtol)); + _ifList.append(new If_Float("prg_int_rho", &_rho)); + _ifList.append(new If_Float("prg_int_tau", &_tau)); + _ifList.append(new If_Int("prg_int_out", &_output)); + _ifList.append(new If_Bool("prg_int_multrec", &_multiple_record)); + +} + +//-------------------------------------------------------------------------- + +Omu_IntOdeTs::~Omu_IntOdeTs() +{ + + int i; + + M_FREE(_Sxd); + M_FREE(_Sxd0); + M_FREE(_Sxx); + M_FREE(_Sxx0); + M_FREE(_Sxu); + M_FREE(_Sxu0); + M_FREE(_Sh); + + V_FREE(_x); + V_FREE(_u); + V_FREE(_a); + + + if(_adtaylor) + free_adtaylor(); + + + if(_nz != NULL) { + for(i = 0; i < _nd+_n+_m; i++) + delete[] _nz[i]; + delete[] _nz; + } +} + +//-------------------------------------------------------------------------- +void Omu_IntOdeTs::realloc(int nd, int n, int nv, int m, int deg) +{ + if (nd == _nd && n == _n && m == _m && nv == _nv && (deg+1) <= _max_deg) + return; + + int i; + + if (nd == _nd && n == _n && m == _m && nv == _nv) { + + if(_adtaylor) + free_adtaylor(); + + _max_deg = deg+1; + + _aa1 = myalloc1(_nd+_n+_m); + _ab1 = myalloc1(_nd+_n+_m); + _aa = myalloc2(_nd+_n+_m,_max_deg); + _ab = myalloc2(_nd+_n+_m,_max_deg); + _ai = myalloc2(_nd+_n+_m,_nd+_n+_m); + _aA = myalloc3(_nd+_n+_m,_nd+_n+_m,_max_deg); + _aB = myalloc3(_nd+_n+_m,_nd+_n+_m,_max_deg); + _adtaylor = true; + + } + else { + + if(_nz != NULL) { + for(i = 0; i < _nd+_n+_m; i++) + delete[] _nz[i]; + delete[] _nz; + } + + _n = n; + _m = m; + _nv = nv; + + assert(_nv == 0); // not supported by Ode + + + v_resize(_a,_nd+_n+_m); + v_resize(_x,_nd+_n+_m); + + m_resize(_Sxd0,_n,_nd); + m_resize(_Sxd,_n,_nd); + m_resize(_Sxx,_n,_n); + m_resize(_Sxx0,_n,_n); + m_resize(_Sxu,_n,_m); + m_resize(_Sxu0,_n,_m); + m_resize(_Sh,_n,_n); + + _nz = new short*[_nd+_n+_m]; + for(i = 0; i < _nd+_n+_m; i++) + _nz[i] = new short[_nd+_n+_m]; // set up sparsity array + + if(_adtaylor) + free_adtaylor(); + + _max_deg = deg+1; + + _aa1 = myalloc1(_nd+_n+_m); + _ab1 = myalloc1(_nd+_n+_m); + _aa = myalloc2(_nd+_n+_m,_max_deg); + _ab = myalloc2(_nd+_n+_m,_max_deg); + _ai = myalloc2(_nd+_n+_m,_nd+_n+_m); + _aA = myalloc3(_nd+_n+_m,_nd+_n+_m,_max_deg); + _aB = myalloc3(_nd+_n+_m,_nd+_n+_m,_max_deg); + _adtaylor = true; + } + +} + + +//-------------------------------------------------------------------------- + +void Omu_IntOdeTs::solve(int kk, Real tstart, Real tend, + const Omu_States &x, const Omu_Vector &u, + Omu_Program *sys, VECP xt, + MATP Sx, MATP Su) +{ + + bool one_step, multiple_record; + short tag; + int deg, i, j, k, n, rc, tayl_finite; + double err, h, hp, t, taut, tayl_max; + adouble au0; + + VECP hpv; + + multiple_record = true; + tag = 1; + + realloc(_nd, _nxt - _nd - _nv, _nv, _nu,_max_deg0); + + adoublev ax(_nd+_n); + adoublev axp(_nd+_n); + adoublev au(_m); + adoublev aF(_nd+_n); + + double f[_nd+_n+_m]; + + if(_tau <= 0) { + printf("time scaling must be greather then zero!\n"); + printf("use original time\n"); + _tau = 1.0; + } + + h = (tend - tstart); + + if(h <= 0.0) + return; + + if(_output > 0) { + printf("t0: %g tf: %g max_deg: %d\n",tstart,tend,_max_deg-1); + v_output(xt); + } + + hpv = v_get(_max_deg); + + rc = 3; + one_step = false; + t = tstart; + n = _nd + _n + _m; + au0 = 0.0; + + for(i = 0; i < _nd+_n; i++) + _a[i] = xt[i]; + for(i = 0; i < _m; i++) + _a[i+_nd+_n] = u[i]; + + if(_sa) { + m_move(Sx,_nd,0,_n,_nd,_Sxd0,0,0); + m_move(Sx,_nd,_nd,_n,_n,_Sxx0,0,0); + m_move(Su,_nd,0,_n,_m,_Sxu0,0,0); + } + + while(t < tend) { + + _res_evals++; + if(_sa) + _sen_evals++; + + err = _atol; + hp = 1.0; + deg = 0; + tayl_finite = 1; + + if(multiple_record) { + + trace_on(tag); + + for (i = 0; i < _nd+_n; i++) + axp[i] = 0.0; + for (i = 0; i < _nd+_n; i++) + aF[i] = 0.0; + + for(i = 0; i < _nd+_n; i++) + ax[i] <<= _a[i]; + for(i = 0; i < _m; i++) + au[i] <<= _a[i+_nd+_n]; + + sys->continuous(_kk, t, ax, au, axp, aF); + + for (i = 0; i < _nd+_n; i++) + aF[i] >>= f[i]; + for(i = 0; i < _m; i++) + au0 >>= f[i+_nd+_n]; + + trace_off(); + + if(!_multiple_record) + multiple_record = false; + + } + + for(i = 0; i < n; i++) { + _aa1[i] = _a[i]; + for(j = 0; j < _max_deg; j++) + _aa[i][j] = 0.0; + } + + mindec(rc,zos_forward(tag,n,n,0,_aa1,_ab1)); + + if( rc < 0) + error(E_INTERN,"Omu_IntOdeTs::solve"); + + taut = _tau/(1+deg); + tayl_max = 0.0; + + for (i=0;i 0; k--) + _aa[i][k] = _aa[i][k-1]; + _aa[i][0] = _aa1[i]; + } + + // determine h + if(!one_step) { + h = _tau*pow(err*(1.0-_rho)/tayl_max,1.0/(1.0*deg)); + if((tend - (t + h)) < h/3.0) + h = 2.0*h/3.0; + h = min(h,tend-t); + } + + if(h == 0.0) { + error(E_SING,"Omu_IntOdeTs::solve"); + printf("Taylor-coeficient: %g \n",tayl_max); + } + + if(_output > 0) + printf("deg: %d time step: %g\n",deg+1,h); + + if(_output > 1) { + printf("taylor-series:\n"); + for(j = 0; j < n; j++) { + for(i = 0; i < (deg+1); i++) + printf("%g ",_aa[j][i]); + printf("\n"); + } + } + + for(i = _nd; i < _nd+_n; i++) { + _a[i] = 0.0; + } + + // compute continuous states after step + hp = 1.0; + + for(j = 0; j < deg+1; j++) { + for(i = _nd; i < _nd+_n; i++) { + _a[i] += _aa[i][j]*hp; + } + hp *= h/_tau; + hpv[j] = hp; + + } + + hp *= h/_tau; + hpv[deg+1] = hp; + + if(_sa) { + + for(i = 0; i < n; i++) { + for(j = 0; j < n; j++) + _ai[i][j] = 0.0; + _ai[i][i] = 1.0; + } + + hov_reverse(tag,n,n,deg,n,_ai,_aA,_nz); + + accodec(n,_tau,deg,_aA,_aB,_nz); + + if(_sa && (_output > 3)) { + for(i=0;i 0) { + m_output(Sx); + m_output(Su); + } + } + + + + for(i = _nd; i < _nd+_n; i++) + xt[i] = _a[i]; + + if(_output > 0) + v_output(xt); + + V_FREE(hpv); + +} + +//-------------------------------------------------------------------------- + +void Omu_IntOdeTs::free_adtaylor() +{ + + if(_adtaylor) { + free((char*) _aa1); + free((char*) _ab1); + free((char*) *_aa); free((char*) _aa); + free((char*) *_ab); free((char*) _ab); + free((char*) *_ai); free((char*) _ai); + free((char*)**_aA); free((char*)*_aA); free((char*)_aA); + free((char*)**_aB); free((char*)*_aB); free((char*)_aB); + + _adtaylor = false; + + } + +} + + + + + + + + + + + diff --git a/omu/Omu_IntOdeTs.h b/omu/Omu_IntOdeTs.h new file mode 100644 index 0000000..518c18f --- /dev/null +++ b/omu/Omu_IntOdeTs.h @@ -0,0 +1,101 @@ +/* + * Omu_IntOdeTs.h -- + * -- class for integrating an Ode over a stage + * -- using Taylor series + * + * hl, 28/01/98 + */ + +/* + Copyright (C) 1997--1999 Hartmut Linke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Omu_IntOdeTs_H +#define Omu_IntOdeTs_H + +#include "Omu_Integrator.h" + +//-------------------------------------------------------------------------- +class Omu_IntOdeTs: public Omu_Integrator { + + public: + + Omu_IntOdeTs(int ); + Omu_IntOdeTs(); + ~Omu_IntOdeTs(); + + char *name() {return "OdeTs";} + + // interface routine from Omu_Integrator + void solve(int kk, Real tstart, Real tend, + const Omu_States &x, const Omu_Vector &u, + Omu_Program *sys, VECP xt, + MATP Sx, MATP Su); + + private: + + bool _adtaylor; + bool _multiple_record; + + int _output; + + int _n; // number of continuous states + int _m; // number of controls + + int _max_deg; + int _max_deg0; + + double _rho; + double _tau; + +/* double _atol; */ +/* double _rtol; */ + + VECP _x; + VECP _u; + + VECP _a; + + MATP _Sxd; + MATP _Sxd0; + MATP _Sxx; + MATP _Sxx0; + MATP _Sxu; + MATP _Sxu0; + MATP _Sh; + + short **_nz; // sparsity pattern + + double *_aa1; + double *_ab1; + double **_aa; + double **_ab; + double **_ai; + double ***_aA; + double ***_aB; + + void realloc(int , int , int , int , int ); + void free_adtaylor(); + +}; + +#endif + + + + diff --git a/omu/Omu_IntRK4.C b/omu/Omu_IntRK4.C new file mode 100644 index 0000000..15a9611 --- /dev/null +++ b/omu/Omu_IntRK4.C @@ -0,0 +1,93 @@ +/* + * Omu_IntRK4.C -- + * -- class implementation + * + * rf, 10/2/96 + */ + +/* + Copyright (C) 1997--2001 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include + +#include + +#include +#include +#include + +#include "Omu_IntRK4.h" + +IF_CLASS_DEFINE("RK4", Omu_IntRK4, Omu_Integrator); + +//-------------------------------------------------------------------------- +Omu_IntRK4::Omu_IntRK4() +{ + _y1 = v_get(1); + _yh = v_get(1); + _fh = v_get(1); +} + +//-------------------------------------------------------------------------- +Omu_IntRK4::~Omu_IntRK4() +{ + v_free(_fh); + v_free(_yh); + v_free(_y1); +} + +//-------------------------------------------------------------------------- +void Omu_IntRK4::ode_solve(Real tstart, VECP y, const VECP u, Real tend) +{ + Real t, dt; + int i, nsteps; + int neq = y->dim; + + v_resize(_y1, neq); + v_resize(_yh, neq); + v_resize(_fh, neq); + + if (_stepsize > 0.0) + nsteps = (int)ceil((tend - tstart) / _stepsize); + else + nsteps = 1; + dt = (tend - tstart) / nsteps; + + for (i = 0; i < nsteps; ++i) { + t = tstart + i*dt; + + syseq(t, y, u, _fh); + v_mltadd(y, _fh, dt/6.0, _y1); + + v_mltadd(y, _fh, dt/2.0, _yh); + syseq(t+dt/2.0, _yh, u, _fh); + v_mltadd(_y1, _fh, dt/3.0, _y1); + + v_mltadd(y, _fh, dt/2.0, _yh); + syseq(t+dt/2.0, _yh, u, _fh); + v_mltadd(_y1, _fh, dt/3.0, _y1); + + v_mltadd(y, _fh, dt, _yh); + syseq(t+dt, _yh, u, _fh); + v_mltadd(_y1, _fh, dt/6.0, y); + } +} + + +//======================================================================== diff --git a/omu/Omu_IntRK4.h b/omu/Omu_IntRK4.h new file mode 100644 index 0000000..99d216c --- /dev/null +++ b/omu/Omu_IntRK4.h @@ -0,0 +1,56 @@ +/* + * Omu_IntRK4.h -- + * -- integrate ODE over a stage using a simple RK4 rule + * + * rf, 10/2/96 + * + * rf, 11/13/96 + * -- use base class Omu_IntODE + */ + +/* + Copyright (C) 1997--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Omu_IntRK4_H +#define Omu_IntRK4_H + +#include "Omu_IntODE.h" + +//-------------------------------------------------------------------------- +class Omu_IntRK4: public Omu_IntODE { + + public: + + Omu_IntRK4(); + ~Omu_IntRK4(); + + char *name() {return "RK4";} + + // interface routine + void ode_solve(Real tstart, VECP y, const VECP u, Real tend); + + private: + + VECP _y1; + VECP _yh; + VECP _fh; +}; + +#endif + diff --git a/omu/Omu_IntRKsuite.C b/omu/Omu_IntRKsuite.C new file mode 100644 index 0000000..9eb1236 --- /dev/null +++ b/omu/Omu_IntRKsuite.C @@ -0,0 +1,181 @@ +/* + * Omu_IntRKsuite.C -- + * -- class implementation + * + * rf, 10/2/96 + */ + +/* + Copyright (C) 1997--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include + +#include +#include +#include + +#include "Omu_IntRKsuite.h" + +IF_CLASS_DEFINE("RKsuite", Omu_IntRKsuite, Omu_Integrator); + +#if defined(HAVE_G2C_H) || defined(HAVE_F2C_H) +# ifdef min +# undef min +# endif +# ifdef max +# undef max +# endif +# if defined(HAVE_G2C_H) +# include +# else +# include +# endif +#else +typedef long int integer; +typedef long int logical; +typedef double doublereal; +#endif +typedef doublereal dreal; + +typedef void (f_t)(dreal *T, dreal *Y, dreal *YP); + +extern "C" { + void setup_(integer *NEQ, dreal *TSTART, dreal *YSTART, dreal *TEND, + dreal *TOL, dreal *THRES, integer *METHOD, char *TASK, + logical *ERRASS, dreal *HSTART, dreal *WORK, integer *LENWRK, + logical *MESAGE); + void reset_(dreal *TENDNU); + void ct_(f_t *F, dreal *TNOW, dreal *YNOW, dreal *YPNOW, dreal *WORK, + integer *CFLAG); + void stat_(integer *TOTF, integer *STPCST, dreal *WASTE, integer *STPSOK, + dreal *HNEXT); +} + +static Omu_IntRKsuite *theOmu_IntRKsuite; + +//-------------------------------------------------------------------------- +static void F(dreal *T, dreal *Y, dreal *YP) +{ + theOmu_IntRKsuite->F(T, Y, YP); +} + +//-------------------------------------------------------------------------- +Omu_IntRKsuite::Omu_IntRKsuite() +{ + theOmu_IntRKsuite = this; + + _y_head.max_dim = 0; + _yp_head.max_dim = 0; + _yp = v_get(1); + _u = v_get(1); + _work = v_get(1); + _thres = v_get(1); +// _rtol = 1e-6; +// _atol = 1e-12; + _hnext = 0.0; + _tlast = 0.0; + _method = 2; + +// _ifList.append(new If_Float("prg_int_rtol", &_rtol)); +// _ifList.append(new If_Float("prg_int_atol", &_atol)); + _ifList.append(new If_Int("prg_int_method", &_method)); +} + +//-------------------------------------------------------------------------- +Omu_IntRKsuite::~Omu_IntRKsuite() +{ + v_free(_thres); + v_free(_work); + v_free(_u); + v_free(_yp); +} + +//-------------------------------------------------------------------------- +void Omu_IntRKsuite::ode_solve(Real tstart, VECP y, const VECP u, Real tend) +{ + if (_sa) + _neq = y->dim; + else + _neq = _n; + _npar = u->dim; + + v_resize(_work, 32 * _neq); + v_resize(_thres, _neq); + v_resize(_u, _npar); + v_resize(_yp, _neq); + _y_head.dim = _neq; + _yp_head.dim = _neq; + + v_set(_thres, _atol); + + // exclude sensitivities from error test + if (!_serr) { + for (int i = _n; i < (int)_thres->dim; i++) + _thres[i] = 1e128; + } + + v_zero(_yp); + v_copy(u, _u); + + integer NEQ = _neq; + + // a hack to reinitialize _hnext in each simulation + if (tstart < _tlast) + _hnext = 0.0; + _tlast = tstart; + + dreal TNOW = tstart; + integer CFLAG; + + //integer METHOD = (_rtol > 5e-4)? 1: (_rtol > 5e-6)? 2: 3; + integer METHOD = _method; + char TASK = 'c'; + logical ERRASS = 0; + dreal HSTART = _hnext; + integer LENWRK = _work->dim; + logical MESAGE = 0; + + setup_(&NEQ, &tstart, y->ve, &tend, &_rtol, _thres->ve, + &METHOD, &TASK, &ERRASS, &HSTART, _work->ve, &LENWRK, &MESAGE); + + while (TNOW < tend) { + ct_(&::F, &TNOW, y->ve, _yp->ve, _work->ve, &CFLAG); + if (CFLAG > 1) + fprintf(stderr, "RKsuite message %d at time %g\n", CFLAG, TNOW); + if (CFLAG > 4) + error(E_UNKNOWN, "Omu_IntRKsuite::step"); + } + + integer TOTF, STPCST, STPSOK; + dreal WASTE; + stat_(&TOTF, &STPCST, &WASTE, &STPSOK, &HSTART); + _hnext = HSTART; +} + +//-------------------------------------------------------------------------- +void Omu_IntRKsuite::F(Real *T, Real *Y, Real *YP) +{ + _y_head.ve = Y; + _yp_head.ve = YP; + + syseq(*T, &_y_head, _u, &_yp_head); +} + + +//======================================================================== diff --git a/omu/Omu_IntRKsuite.h b/omu/Omu_IntRKsuite.h new file mode 100644 index 0000000..4f92fd0 --- /dev/null +++ b/omu/Omu_IntRKsuite.h @@ -0,0 +1,66 @@ +/* + * Omu_IntRKsuite.h -- + * -- integrate ODE over a stage using RKsuite + * + * rf, 11/13/96 + */ + +/* + Copyright (C) 1997--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Omu_IntRKsuite_H +#define Omu_IntRKsuite_H + +#include "Omu_IntODE.h" + +//-------------------------------------------------------------------------- +class Omu_IntRKsuite: public Omu_IntODE { + + public: + + Omu_IntRKsuite(); + ~Omu_IntRKsuite(); + + char *name() {return "RKsuite";} + + // interface routine + void ode_solve(Real tstart, VECP y, const VECP u, Real tend); + + // callback for calculation of system equations + void F(Real *T, Real *Y, Real *YP); + + private: + + int _neq; + int _npar; +/* Real _rtol; */ +/* Real _atol; */ + Real _hnext; + Real _tlast; + int _method; + VECP _thres; + VECP _work; + VECP _u; + VECP _yp; + VEC _y_head; + VEC _yp_head; +}; + +#endif + diff --git a/omu/Omu_IntSDIRK.C b/omu/Omu_IntSDIRK.C new file mode 100644 index 0000000..b05c312 --- /dev/null +++ b/omu/Omu_IntSDIRK.C @@ -0,0 +1,1442 @@ +/* + * Omu_IntSDIRK.C -- + * -- class for integrating an Ode over a stage + * -- using implicit Runge Kutta method + * + * hl, 31/07/00 + */ + +/* + Copyright (C) 2000 Hartmut Linke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include +#include +#include + +#include + +#include +#include +#include +#include +#include +#include + +#include "Omu_IntSDIRK.h" + +extern "C" { +#include +} + +IF_CLASS_DEFINE("SDIRK", Omu_IntSDIRK, Omu_Integrator); + +//-------------------------------------------------------------------------- + +Omu_IntSDIRK::Omu_IntSDIRK() +{ + + _recalc_jac = true; + _stiffly_accurate = false; + _sens_at_once = false; + + _output = 0; + _n_splitt_tape_eval = 30; + _tag = 10; + + _x_algebraic = iv_get(1); + + _ppivot= px_get(1); + _Spivot= px_get(1); + + _cx = v_get(1); + _cu = v_get(1); + _cxp = v_get(1); + _cF = v_get(1); + _cFh = v_get(1); + + _par = v_get(1); + _y = v_get(1); + _y0 = v_get(1); + _yprime0 = v_get(1); + _yprime1 = v_get(1); + _yprime2 = v_get(1); + _irk_delta = v_get(1); + _irk_res = v_get(1); + _irk_y = v_get(1); + _irk_yprime = v_get(1); + + _yprime = m_get(1,1); + + _cFx = m_get(1,1); + _cFxh = m_get(1,1); + _cFu = m_get(1,1); + _cFxp = m_get(1,1); + _Sxd = m_get(1,1); + _Sxd0 = m_get(1,1); + _Sxx = m_get(1,1); + _Sxx0 = m_get(1,1); + _Sxu = m_get(1,1); + _Sxu0 = m_get(1,1); + _SF = m_get(1,1); + _Sh = m_get(1,1); + + _U = m_get(1,1); + _Z = m_get(1,1); + + _nz = NULL; + + _irk_jac = m_get(1,1); + _irk_jacf = m_get(1,1); + + _na = 0; + _nod = 0; + + _ml = 0; + _mu = 0; + + _nsteps = 0; + _modnewtonsteps = 5; + _newtonsteps = 0; + _maxiters = 20; + + _hinit = 0.0; + _h = 0.0; + _h_new = 0.0; + + _err = v_get(1); + + // irk parameters + + _irk_stages = 0; + _a = m_get(1,1); + _a_pred = m_get(1,1); + _c = v_get(1); + _b = v_resize(v_get(1),0); + _b_err = v_resize(v_get(1),0); + + _gamma0 = 1.0; + + _ifList.append(new If_Bool("prg_int_sens", &_sens_at_once)); + _ifList.append(new If_Int("prg_int_out", &_output)); + _ifList.append(new If_Int("prg_int_nsteps", &_nsteps)); + _ifList.append(new If_Int("prg_int_nsplitt", &_n_splitt_tape_eval)); + _ifList.append(new If_Int("prg_int_modnewtonsteps", &_modnewtonsteps)); + _ifList.append(new If_Int("prg_int_maxiters", &_maxiters)); + _ifList.append(new If_Float("prg_int_hinit", &_hinit)); + + init_method(); + +} + +//-------------------------------------------------------------------------- + +Omu_IntSDIRK::~Omu_IntSDIRK() +{ + + int i; + + IV_FREE(_x_algebraic); + + PX_FREE(_ppivot); + PX_FREE(_Spivot); + + V_FREE(_cx); + V_FREE(_cu); + V_FREE(_cxp); + V_FREE(_cF); + V_FREE(_cFh); + V_FREE(_par); + V_FREE(_y); + V_FREE(_y0); + V_FREE(_yprime0); + V_FREE(_yprime1); + V_FREE(_yprime2); + V_FREE(_irk_delta); + V_FREE(_irk_res); + V_FREE(_irk_y); + V_FREE(_irk_yprime); + + V_FREE(_err); + + V_FREE(_b); + V_FREE(_b_err); + V_FREE(_c); + M_FREE(_a); + M_FREE(_a_pred); + + M_FREE(_yprime); + M_FREE(_cFx); + M_FREE(_cFxh); + M_FREE(_cFu); + M_FREE(_cFxp); + + M_FREE(_Sxd); + M_FREE(_Sxd0); + M_FREE(_Sxx); + M_FREE(_Sxx0); + M_FREE(_Sxu); + M_FREE(_Sxu0); + M_FREE(_SF); + M_FREE(_Sh); + + M_FREE(_U); + M_FREE(_Z); + M_FREE(_irk_jac); + M_FREE(_irk_jacf); + + if(_nz != NULL) { + for(i = 0; i < _nd+_n+_m; i++) + delete[] _nz[i]; + delete[] _nz; + } + +} + +//-------------------------------------------------------------------------- +void Omu_IntSDIRK::init_method() +{ + + int i; + + _irk_stages = 5; + + m_resize(_a,5,5); + m_zero(_a); + _a[0][0] = 1.0/4.0; + _a[1][0] = 1.0/2.0; + _a[1][1] = 1.0/4.0; + _a[2][0] = 1.7e1/5.0e1; + _a[2][1] = -1.0/2.5e1; + _a[2][2] = 1.0/4.0; + _a[3][0] = 3.71e2/1.36e3; + _a[3][1] = -1.37e2/2.72e3; + _a[3][2] = 1.5e1/5.44e2; + _a[3][3] = 1.0/4.0; + _a[4][0] = 2.5e1/2.4e1; + _a[4][1] = -4.9e1/4.8e1; + _a[4][2] = 1.25e2/1.6e1; + _a[4][3] = -8.5e1/1.2e1; + _a[4][4] = 1.0/4.0; + + v_resize(_c,5); + _c[0] = 1.0/4.0; + _c[1] = 3.0/4.0; + _c[2] = 11.0/20.0; + _c[3] = 1.0/2.0; + _c[4] = 1.0; + + v_resize(_b,5); + _b[0] = 2.5e1/2.4e1; + _b[1] = -4.9e1/4.8e1; + _b[2] = 1.25e2/1.6e1; + _b[3] = -8.5e1/1.2e1; + _b[4] = 1.0/4.0; + + v_resize(_b_err,5); + _b_err[0] = 5.9e1/4.8e1; + _b_err[1] = -1.7e1/9.6e1; + _b_err[2] = 2.25e2/3.2e1; + _b_err[3] = -8.5e1/1.2e1; + _b_err[4] = 0.0; + + if(_c[_c->dim-1] == 1.0) { + _stiffly_accurate = true; + for(i = 0; i < _irk_stages; i++) + if(_b[i] != _a[_irk_stages-1][i]) { + _stiffly_accurate = false; + break; + } + } + + init_yprime_pred(_a_pred); + + _gamma0 = 1.0/4.000271085; + +} + +//-------------------------------------------------------------------------- + +void Omu_IntSDIRK::init_yprime_pred(MATP pred) +{ + + // simple linear interpolation + + m_resize(pred,_irk_stages,_irk_stages+1); + + pred[0][0] = 2.0; + pred[0][2] = -1.0; + pred[1][0] = -2.0; + pred[1][1] = 3.0; + pred[2][1] = 0.5; + pred[2][2] = 0.5; + pred[3][3] = 1.0; + pred[4][2] = -1.0; + pred[4][4] = 2.0; + +} + +//-------------------------------------------------------------------------- +void Omu_IntSDIRK::realloc() +{ + + int i; + + if (_cx->dim == _nd + _n && _cu->dim == _nu) + return; + + // + // realloc variables for low level _sys->continuous callback + // + + iv_resize(_x_algebraic,_n); + + v_resize(_cx, _nd + _n); + v_resize(_cu, _nu); + v_resize(_cxp, _nd + _n); + v_resize(_cF, _nd + _n); + v_resize(_cFh, _n); + + v_resize(_par, _nd+_nu); + v_resize(_y, _n); + v_resize(_y0, _n); + v_resize(_yprime0, _n); + v_resize(_yprime1, _n); + v_resize(_yprime2, _n); + + m_resize(_yprime, _irk_stages, _n); + + m_resize(_cFx, _nd + _n, _nd + _n); + m_resize(_cFxh, _n, _n); + m_resize(_cFu, _nd + _n, _nu); + m_resize(_cFxp, _nd + _n, _nd + _n); + + m_resize(_Sxd0,_n,_nd); + m_resize(_Sxd,_n,_nd); + m_resize(_Sxx,_n,_n); + m_resize(_Sxx0,_n,_n); + m_resize(_Sxu,_n,_nu); + m_resize(_Sxu0,_n,_nu); + m_resize(_SF,_irk_stages*_n,_irk_stages*_n); + m_resize(_Sh,_irk_stages*_n,_nd+_n+_nu); + px_resize(_Spivot,_irk_stages*_n); + + v_resize(_err,_n); + + px_resize(_ppivot,_n); + v_resize(_irk_delta,_n); + v_resize(_irk_res,_n); + v_resize(_irk_y,_n); + v_resize(_irk_yprime,_n); + m_resize(_irk_jac,_n,_n); + m_resize(_irk_jacf,_n,_n); + + if(_nz != NULL) { + for(i = 0; i < _n; i++) + delete[] _nz[i]; + delete[] _nz; + } + + // set up sparsity array + _nz = new short*[_n]; + for(i = 0; i < _n; i++) + _nz[i] = new short[_n+_nd+_nu]; + +} + + +//-------------------------------------------------------------------------- +void Omu_IntSDIRK::init_stage(int k, + const Omu_States &x, const Omu_Vector &u, + bool sa) +{ + + int i, j; + + Omu_Integrator::init_stage(k, x, u, sa); + + if(x.na > 0) { + _na = x.na; + iv_resize(_x_algebraic,x->dim); + iv_zero(_x_algebraic); + for(i = 0; i < _n; i++) { + if(x.flags[_nd+i] & Omu_States::Algebraic) + _x_algebraic[i] = 1; // indicate algebraic state + } + } + + // check for sdirk method + for(i = 0; i < _irk_stages-1; i++) + for(j = i+1; j < _irk_stages; j++) + if(_a[i][j] != 0.0) + error(E_INTERN,"Omu_IntSDIRK::init_stage - + sdirk method not correctly defined!"); + + for(i = 1; i < _irk_stages; i++) + if(_a[i][i] != _a[0][0]) + error(E_INTERN,"Omu_IntSDIRK::init_stage - + sdirk method not correctly defined!"); + + realloc(); + +} + +//-------------------------------------------------------------------------- + +void Omu_IntSDIRK::solve(int kk, Real tstart, Real tend, + const Omu_States &x, const Omu_Vector &u, + Omu_Program *sys, VECP xt, + MATP Sx, MATP Su) +{ + + bool ok, tend_ok; + int i, j, l, n, nv, m, steps; + double err; + + if(_output > 1) { + cout << endl; + cout << "Omu_IntSDIRK::solve at stage " << kk; + cout.precision(16); + cout << " tstart: " << tstart; + cout << " tend: " << tend << endl; + cout.precision(8); + v_output(xt); + } + + _sys = sys; // propagate to res() and jac() + + m_zero(_cFx); + m_zero(_cFu); + m_zero(_cFxp); + m_zero(_Sxx0); + + _nod = 0; + + if(_sa) { + m_move(Sx,_nd,0,_n-_nod,_nd,_Sxd0,0,0); + m_move(Sx,_nd,_nd,_n,_n-_nod,_Sxx0,0,0); + m_move(Su,_nd,0,_n,_nu,_Sxu0,0,0); + } + + // compute initial values for yprime + v_zero(_yprime0); + for(i = 0; i < _n; i++) + _yprime0[i] = 1.0e-5; + init_yprime(kk,tstart,xt,u,_yprime0); + + if(_nsteps > 0) + _h_new = (tend - tstart)/_nsteps; + else + if(_hinit > 0.0) + _h_new = min(_hinit,tend-tstart); + else + _h_new = (tend - tstart)/1.0e2; + // error(E_INTERN,"Omu_IntSDIRK::solve no step size provided"); + + v_zero(_y); + + for (i = 0; i < _nd; i++) + _par[i] = xt[i]; + + for (i = 0; i < _n; i++) + _y[i] = xt[_nd + i]; // initial states + + for (i = 0; i < _nu; i++) + _par[_nd + i] = u[i]; + + v_zero(_irk_delta); + + _h = _h_new; + _t = tstart; + + for(i = 0; i < _n; i++) + if(_x_algebraic[i]) + _yprime0[i] = _y[i]; + + set_row(_yprime,1,_yprime0); + + tend_ok = false; + steps = 0; + + while(_t < tend) { + + steps++; + + if(_t + _h >= tend) { + _h = tend - _t; + tend_ok = true; + } + + if(_nsteps > 0 && steps == _nsteps) + tend_ok = true; + + v_copy(_y,_y0); + v_copy(_yprime0,_yprime1); + set_row(_yprime,0,_yprime0); + ok = true; + _newtonsteps = 0; + + do { + + // solve stages subsequently + + for(i = 0; i < _irk_stages; i++) { + + // prepare y and yprime for the current stage + + v_copy(_y0,_y); + v_zero(_yprime0); + + for(j = 0; j < i; j++) + for(l = 0; l < _n; l++) + _yprime0[l] += _a_pred[i][0]*_yprime1[l]; + + for(j = 0; j < i; j++) + for(l = 0; l < _n; l++) + _yprime0[l] += _a_pred[i][j+1]*_yprime[j][l]; + + for(j = 0; j < i; j++) + for(l = 0; l < _n; l++) + if(!_x_algebraic[l]) + _y[l] += _h*_a[i][j]*_yprime[j][l]; + + solve_stage(i+1,_y,_yprime0); + + for(l = 0; l < _n; l++) + if(_x_algebraic[l]) + _yprime0[l] = _y[l]; + + set_row(_yprime,i,_yprime0); + + } + + // now we have to check the error + + if(_nsteps <= 0) { + if(_b_err->dim == _irk_stages) { + v_copy(_y0,_err); + for(j = 0; j < _irk_stages; j++) + for(l = 0; l < _n; l++) + if(!_x_algebraic[l]) + _err[l] += _h*_b_err[j]*_yprime[j][l]; + else + _err[l] = _y[l]; + /* + if(_na > 0) + solve_final(_err,_yprime2); // to do!!! + */ + } + } + + if(!_stiffly_accurate) { + v_copy(_y0,_y); + for(j = 0; j < _irk_stages; j++) + for(l = 0; l < _n; l++) + if(!_x_algebraic[l]) + _y[l] += _h*_b[j]*_yprime[j][l]; + else + _y[l] = _yprime0[l]; + + if(_na > 0) + solve_final(_y,_yprime0); + } + + if(_nsteps <= 0) { + + // algebraic variables are not considered in the error evaluation + + for(i = 0; i < _n; i++) + if(_x_algebraic[i]) + _yprime1[i] = 0.0; + + v_sub(_err,_y,_irk_y); + jac(-3,_t,_y0,_yprime1,_par,_irk_res); + LUfactor(_irk_jac, _ppivot); + LUsolve(_irk_jac, _ppivot, _irk_y, _err); + + err = 0.0; + + for(i = 0; i < _n; i++) + if(!_x_algebraic[i]) { + _err[i] = _err[i]/(_atol+max(fabs(_y0[i]),fabs(_y[i]))*_rtol); + err = max(err,fabs(_err[i])); + } + else + _err[i] = 0.0; + + err = max(v_norm2(_err)/sqrt(double(_n-_na)),_atol); + + _h_new = 0.9*_h*pow(err,-0.25); + + if(err > 1.0) { + ok = false; + _h = _h_new; + tend_ok = false; + } + else + ok = true; + + if(_output > 1 && !ok) { + cout << "t: " << _t << " err: " << err << " h_new: "; + cout << _h_new << " accepted: " << ok; + cout << " newtonsteps: " << _newtonsteps << endl; + v_output(_err); + } + } + } + while(!ok); + + if(_output > 1) { + cout.precision(16); + cout << "t: " << _t; + cout.precision(8); + cout << " err: " << err << " h_new: "; + cout << _h_new << " accepted: " << ok; + cout << " newtonsteps: " << _newtonsteps << endl; + } + + if(_output > 2) { + cout << "y_hat(t+h) - y(t+h):" << endl; + v_output(_irk_y); + v_output(_irk_res); + } + + if(_sa) + sensitivity(); + + _t += _h; + _h = _h_new; + + if(tend_ok) + break; + + } + + // return results of integration process + for(i = 0; i < _n; i++) + xt[_nd+i] = _y[i]; + + if(_sa) { + m_move(_Sxd0,0,0,_n,_nd,Sx,_nd,0); + m_move(_Sxx0,0,0,_n,_n-_nod,Sx,_nd,_nd); + m_move(_Sxu0,0,0,_n,_nu,Su,_nd,0); + } + +} + +//-------------------------------------------------------------------------- + +void Omu_IntSDIRK::solve_stage(int stage, VECP y, VECP yprime) +{ + + bool ok; + int i, j, l, n, m, an, ap; + double alpha, cur_err, old_err; + + v_ones(_irk_res); + v_copy(y,_irk_y); + v_copy(yprime,_irk_yprime); + + cur_err = 1.0e10; + ok = false; + _recalc_jac = false; + + if(_output > 2) + cout << " stage: " << stage; + + // modified Newton's method + for(i = 0; i < _maxiters; i++ ) { + + if(stage < 2 && (i % _modnewtonsteps) == 0) + _recalc_jac = true; + + alpha = 0.5; + + if(i > 0) { + + do { + + cur_err = 0.0; + // check for convergence + for(ok = true, j = 0 ; j < _n; j++) { + ok = ok && + (fabs(_irk_res[j]) < 1.0e-2*(_atol + _rtol*fabs(_irk_y[j]))); + cur_err = max(cur_err,fabs(_irk_res[j])); + } + + if(cur_err > old_err) { + + if(_output > 2) { + cout << "alpha: " << alpha << " cur_err: " << cur_err; + cout << " old_err: " << old_err << endl; + } + + // do damped step and recalculate jacobian + _recalc_jac = true; + for(j = 0; j < _n; j++) + if(!_x_algebraic[j]) + _irk_yprime[j] -= alpha*_irk_delta[j]; + else + _irk_y[j] -= alpha*_irk_delta[j]; + + alpha = 0.5*alpha; + + v_copy(_irk_y,y); + for(j = 0; j < _n; j++) + if(!_x_algebraic[j]) { + y[j] += _h*_a[stage-1][stage-1]*_irk_yprime[j]; + yprime[j] = _irk_yprime[j]; + } + res(_t+_c[stage-1]*_h, y, yprime,_par,_irk_res); + + } + else { + if(cur_err/old_err > 0.3) + _recalc_jac = true; + break; + } + } while(alpha > 1.0e-2); + } + + if(i > 0 && _output > 2) { + cout << " iter: " << i << " res: " << cur_err; + cout << " oldres: " << old_err; + if(_recalc_jac) + cout << " new jacobian"; + cout << endl; + } + + old_err = cur_err; + + v_copy(_irk_y,y); + for(j = 0; j < _n; j++) + if(!_x_algebraic[j]) { + y[j] += _h*_a[stage-1][stage-1]*_irk_yprime[j]; + yprime[j] = _irk_yprime[j]; + } + + if(ok) + break; + else if (i == _maxiters-1) + error(E_INTERN, + "Omu_IntSDIRK::ode_solve Newton method failed to converge"); + + // (re)calculate and factorize Jacobian + if(_recalc_jac) { + jac(stage,_t+_c[stage-1]*_h, y, yprime,_par,_irk_res); + if(i == 0) { + old_err = 0.0; + // check for convergence + for(ok = true, j = 0 ; j < _n; j++) { + ok = ok && (fabs(_irk_res[j])<0.1*_atol); + old_err = max(old_err,fabs(_irk_res[j])); + } + old_err++; + } + + LUfactor(_irk_jac, _ppivot); + _recalc_jac = false; + } + else + res(_t+_c[stage-1]*_h, y, yprime,_par,_irk_res); + + sv_mlt(-1.0,_irk_res,_irk_res); + LUsolve(_irk_jac, _ppivot, _irk_res, _irk_delta); + + // do step + for(j = 0; j < _n; j++) + if(!_x_algebraic[j]) + _irk_yprime[j] += _irk_delta[j]; + else + _irk_y[j] += _irk_delta[j]; + + } + + _newtonsteps += i; + +} + +//-------------------------------------------------------------------------- + +void Omu_IntSDIRK::solve_final(VECP y, VECP yprime) +{ + + bool ok; + int i, j, l, n, m, an, ap; + double cur_err, old_err; + + v_ones(_irk_res); + v_copy(y,_irk_y); + v_copy(yprime,_irk_yprime); + + cur_err = 1.0e10; + ok = false; + _recalc_jac = false; + + if(_output > 2) + cout << "compute algebraic states and yprime at t+h" << endl; + + // modified Newton's method + for(i = 0; i < _maxiters; i++ ) { + + if((i % _modnewtonsteps) == 0) + _recalc_jac = true; + + if(i > 0) { + cur_err = 0.0; + // check for convergence + for(ok = true, j = 0 ; j < _n; j++) { + ok = ok && (fabs(_irk_res[j]) < 1.0e-2*_atol); + cur_err = max(cur_err,fabs(_irk_res[j])); + } + + if(cur_err > old_err) { + // do damped step and recalculate jacobian + _recalc_jac = true; + for(j = 0; j < _n; j++) + if(_x_algebraic[j]) + _irk_y[j] += 0.2*_irk_delta[j]; + else + _irk_yprime[j] += 0.2*_irk_delta[j]; + } + else { + // do full step + for(j = 0; j < _n; j++) + if(_x_algebraic[j]) + _irk_y[j] += _irk_delta[j]; + else + _irk_yprime[j] += _irk_delta[j]; + + if(cur_err/old_err > 0.3) + _recalc_jac = true; + } + } + + if(_output > 2) { + cout << " iter: " << i << " res: " << cur_err; + cout << " oldres: " << old_err; + if(_recalc_jac) + cout << " new jacobian"; + cout << endl; + } + + old_err = cur_err; + + v_copy(_irk_y,y); + v_copy(_irk_yprime,yprime); + + if(ok) + break; + else if (i == _maxiters-1) + error(E_INTERN, + "Omu_IntSDIRK::ode_solve Newton method failed to converge"); + + // (re)calculate and factorize Jacobian + if(_recalc_jac) { + jac(0,_t+_h, y, yprime,_par,_irk_res); + if(i == 0) { + old_err = 0.0; + // check for convergence + for(ok = true, j = 0 ; j < _n; j++) { + ok = ok && (fabs(_irk_res[j])<0.1*_atol); + old_err = max(old_err,fabs(_irk_res[j])); + } + old_err++; + } + + LUfactor(_irk_jac, _ppivot); + _recalc_jac = false; + + } + else + res(_t+_h, y, yprime,_par,_irk_res); + + sv_mlt(-1.0,_irk_res,_irk_res); + LUsolve(_irk_jac, _ppivot, _irk_res, _irk_delta); + + } + + _newtonsteps += i; + +} + + +//-------------------------------------------------------------------------- +// differentiate the whole integration scheme using adol-c + +void Omu_IntSDIRK::sensitivity() +{ + + int i, j, l, m; + + double aindep[_irk_stages*_n+_n+_nd+_nu]; + double f[_irk_stages*_n]; + + adoublev au(_nu); + adoublev ay(_nd+_n); + adoublev ay0(_nd+_n); + adoublev ayprime(_nd+_n); + adoublev aF(_nd+_n); + adoublev irk_ay(_irk_stages*(_nd+_n)); + adoublev irk_ayprime(_irk_stages*(_nd+_n)); + adoublev irk_aF(_irk_stages*(_nd+_n)); + + trace_on(_tag,1); + + // initialize variables + + for (i = 0; i < _nd+_n; i++) + aF[i] = 0.0; + + for (i = 0; i < _irk_stages*(_nd+_n); i++) { + irk_ay[i] = 0.0; + irk_ayprime[i] = 0.0; + } + + for(i = 0; i < _nd; i++) { + aindep[i] = _par[i]; + ay0[i] <<= aindep[i]; + } + + for(i = 0; i < _n; i++) { + aindep[_nd+i] = _y0[i]; + ay0[_nd+i] <<= aindep[_nd+i]; + } + + for(i = 0; i < _nu; i++) { + aindep[_nd+_n+i] = _par[_nd+i]; + au[i] <<= aindep[_nd+_n+i]; + } + + for(i = 0; i < _irk_stages; i++) + for(j = 0; j < _n; j++) + if(!_x_algebraic[j]) { + aindep[_nd+(i+1)*_n+_nu+j] = _yprime[i][j]; + irk_ayprime[i*(_nd+_n)+_nd+j] <<= aindep[_nd+(i+1)*_n+_nu+j]; + } + else { + aindep[_nd+(i+1)*_n+_nu+j] = _yprime[i][j]; + irk_ay[i*(_nd+_n)+_nd+j] <<= aindep[_nd+(i+1)*_n+_nu+j]; + } + + for(i = 0; i < _irk_stages; i++) { + + for(j = 0; j < _nd; j++) { + ay[j] = ay0[j]; + ayprime[j] = 0.0; + } + + for(j = 0; j < _n; j++) + if(!_x_algebraic[j]) { + ay[_nd+j] = ay0[_nd+j]; + for(l = 0; l <= i; l++) + ay[_nd+j] += _h*_a[i][l]*irk_ayprime[l*(_nd+_n)+_nd+j]; + ayprime[_nd+j] = irk_ayprime[i*(_nd+_n)+_nd+j]; + } + else + ay[_nd+j] = irk_ay[i*(_nd+_n)+_nd+j]; + + _sys->continuous(_kk, _t+_c[i]*_h, ay, au, ayprime, aF); + + for(j = 0; j < _nd+_n; j++) + irk_aF[i*(_nd+_n)+j] = aF[j]; + + } + + for(i = 0; i < _irk_stages; i++) + for(j = 0; j < _n; j++) + irk_aF[i*(_nd+_n)+_nd+j] >>= f[i*_n+j]; + + trace_off(); + + if(_sens_at_once) { + + m_resize(_U,_irk_stages*_n,_irk_stages*_n); + m_resize(_Z,_irk_stages*_n,(_irk_stages+1)*_n+_nd+_nu); + m_ident(_U); + m_zero(_Z); + + reverse(_tag, _irk_stages*_n, (_irk_stages+1)*_n+_nd+_nu, 0, + _irk_stages*_n, _U->me, _Z->me); + + m_resize(_SF,_irk_stages*_n,_irk_stages*_n); + m_resize(_irk_jacf,_irk_stages*_n,_irk_stages*_n); + m_move(_Z,0,_n+_nd+_nu,_irk_stages*_n,_irk_stages*_n,_SF,0,0); + m_resize(_Sh,_irk_stages*_n,_n+_nd+_nu); + + m_copy(_SF,_irk_jacf); + LUfactor(_irk_jacf, _Spivot); + + v_resize(_irk_res,_irk_stages*_n); + v_resize(_irk_delta,_irk_stages*_n); + + for(j = 0; j < _nd+_n+_nu; j++) { + get_col(_Z,j,_irk_res); + + if(v_sum(_irk_res) != 0.0) { + sv_mlt(-1.0,_irk_res,_irk_res); + LUsolve(_irk_jacf, _Spivot, _irk_res, _irk_delta); + set_col(_Sh,j,_irk_delta); + } + else + set_col(_Sh,j,_irk_res); + } + } + else { + + // compute sensitivities stagewise + // treat the tape all at once + if(_n < _n_splitt_tape_eval) { + + m_resize(_U,_irk_stages*_n,_irk_stages*_n); + m_resize(_Z,_irk_stages*_n,(_irk_stages+1)*_n+_nd+_nu); + m_ident(_U); + m_zero(_Z); + + reverse(_tag, _irk_stages*_n, (_irk_stages+1)*_n+_nd+_nu, 0, + _irk_stages*_n, _U->me, _Z->me); + + m_resize(_SF,_n,_n+_nd+_nu); + m_resize(_Sxd,_n,_n+_nd+_nu); + m_resize(_Sxu,_n,_n+_nd+_nu); + m_resize(_Sh,_irk_stages*_n,_n+_nd+_nu); + + for(i = 0; i < _irk_stages; i++) { + + m_move(_Z,i*_n,(i+1)*_n+_nd+_nu,_n,_n,_irk_jac,0,0); + m_move(_Z,i*_n,0,_n,_nd+_n+_nu,_Sxd,0,0); + + LUfactor(_irk_jac, _ppivot); + + for(j = 0; j < _nd+_n+_nu; j++) { + get_col(_Sxd,j,_irk_res); + sv_mlt(-1.0,_irk_res,_irk_res); + LUsolve(_irk_jac, _ppivot, _irk_res, _irk_delta); + set_col(_Sxd,j,_irk_delta); + } + + for(j = 0; j < i; j++) { + + m_move(_Z,i*_n,(j+1)*_n+_nd+_nu,_n,_n,_Sxx,0,0); + m_move(_Sh,j*_n,0,_n,_nd+_n+_nu,_SF,0,0); + + for(l = 0; l < _n; l++) { + get_col(_Sxx,l,_irk_res); + sv_mlt(-1.0,_irk_res,_irk_res); + LUsolve(_irk_jac, _ppivot, _irk_res, _irk_delta); + set_col(_Sxx,l,_irk_delta); + } + + m_mlt(_Sxx,_SF,_Sxu); + m_add(_Sxd,_Sxu,_Sxd); + + } + + m_move(_Sxd,0,0,_n,_n+_nd+_nu,_Sh,i*_n,0); + + } + } + else { + + // compute sensitivities stagewise + // treat the tape stagewise + + m_resize(_U,_n,_irk_stages*_n); + m_resize(_Z,_n,(_irk_stages+1)*_n+_nd+_nu); + m_resize(_SF,_n,_n+_nd+_nu); + m_resize(_Sxd,_n,_n+_nd+_nu); + m_resize(_Sxu,_n,_n+_nd+_nu); + m_resize(_Sh,_irk_stages*_n,_n+_nd+_nu); + + m_zero(_U); + + // treat the tape stagewise + for(i = 0; i < _irk_stages; i++) { + + for(j = 0; j < _n; j++) + _U[j][i*_n+j] = 1.0; + + reverse(_tag, _irk_stages*_n, (_irk_stages+1)*_n+_nd+_nu, 0, + _n, _U->me, _Z->me); + + m_move(_Z,0,(i+1)*_n+_nd+_nu,_n,_n,_irk_jac,0,0); + m_move(_Z,0,0,_n,_nd+_n+_nu,_Sxd,0,0); + + LUfactor(_irk_jac, _ppivot); + + for(j = 0; j < _nd+_n+_nu; j++) { + get_col(_Sxd,j,_irk_res); + sv_mlt(-1.0,_irk_res,_irk_res); + LUsolve(_irk_jac, _ppivot, _irk_res, _irk_delta); + set_col(_Sxd,j,_irk_delta); + } + + for(j = 0; j < i; j++) { + + m_move(_Z,0,(j+1)*_n+_nd+_nu,_n,_n,_Sxx,0,0); + m_move(_Sh,j*_n,0,_n,_nd+_n+_nu,_SF,0,0); + + for(l = 0; l < _n; l++) { + get_col(_Sxx,l,_irk_res); + sv_mlt(-1.0,_irk_res,_irk_res); + LUsolve(_irk_jac, _ppivot, _irk_res, _irk_delta); + set_col(_Sxx,l,_irk_delta); + } + + m_mlt(_Sxx,_SF,_Sxu); + m_add(_Sxd,_Sxu,_Sxd); + + } + + m_move(_Sxd,0,0,_n,_n+_nd+_nu,_Sh,i*_n,0); + + for(j = 0; j < _n; j++) + _U[j][i*_n+j] = 0.0; + + } + } + } + + m_resize(_Sxd,_n,_nd); + m_resize(_Sxu,_n,_nu); + v_resize(_irk_res,_n); + v_resize(_irk_delta,_n); + + // Sxd + m_zero(_Sxd); + for(i = 0; i < _n; i++) + if(!_x_algebraic[i]) + for(l = 0; l < _irk_stages; l++) + for(j = 0; j < _nd; j++) + _Sxd[i][j] += _h*_b[l]*_Sh[l*_n+i][j]; + else + for(j = 0; j < _nd; j++) + _Sxd[i][j] = _Sh[(_irk_stages-1)*_n+i][j]; + + // Sxx + m_zero(_Sxx); + for(i = 0; i < _n; i++) + if(!_x_algebraic[i]) + for(l = 0; l < _irk_stages; l++) + for(j = 0; j < _n; j++) + _Sxx[i][j] += _h*_b[l]*_Sh[l*_n+i][_nd+j]; + else + for(j = 0; j < _n; j++) + _Sxx[i][j] = _Sh[(_irk_stages-1)*_n+i][_nd+j]; + + // Sxu + m_zero(_Sxu); + for(i = 0; i < _n; i++) + if(!_x_algebraic[i]) + for(l = 0; l < _irk_stages; l++) + for(j = 0; j < _nu; j++) + _Sxu[i][j] += _h*_b[l]*_Sh[l*_n+i][_nd+_n+j]; + else + for(j = 0; j < _nu; j++) + _Sxu[i][j] = _Sh[(_irk_stages-1)*_n+i][_nd+_n+j]; + + m_resize(_Sh,_n,_nd); + m_mlt(_Sxx,_Sxd0,_Sh); + + for(j = 0; j < _n; j++) + for(l = 0; l < _nd; l++) + if(!_x_algebraic[j]) + _Sxd0[j][l] = _Sxd0[j][l] + _Sxd[j][l] +_Sh[j][l]; + else + _Sxd0[j][l] = _Sxd[j][l] +_Sh[j][l]; + + m_resize(_Sh,_n,_nu); + m_mlt(_Sxx,_Sxu0,_Sh); + + for(j = 0; j < _n; j++) + for(l = 0; l < _nu; l++) + if(!_x_algebraic[j]) + _Sxu0[j][l] = _Sxu0[j][l] + _Sxu[j][l] +_Sh[j][l]; + else + _Sxu0[j][l] = _Sxu[j][l] +_Sh[j][l]; + + m_resize(_Sh,_n,_n); + m_mlt(_Sxx,_Sxx0,_Sh); + for(j = 0; j < _n; j++) + for(l = 0; l < _n; l++) + if(!_x_algebraic[j]) + _Sxx0[j][l] = _Sxx0[j][l] + _Sh[j][l]; + else + _Sxx0[j][l] = _Sh[j][l]; + +} + +//-------------------------------------------------------------------------- +void Omu_IntSDIRK::res(double t, const VECP y, const VECP yprime, + const VECP par, VECP res) +{ + + int i, j; + + // form vectors of independent variables + + for (i = 0; i < _nd; i++) { + _cx[i] = par[i]; + _cxp[i] = 0.0; + } + for (i = 0; i < _n; i++) { + _cx[_nd + i] = y[i]; + _cxp[_nd + i] = yprime[i]; + } + for (i = 0; i < _nu; i++) { + _cu[i] = par[_nd + i]; + } + + // evaluate residual + + _sys->continuous(_kk, t, _cx, _cu, _cxp, _cF); + + for (i = 0; i < _n; i++) + res[i] = _cF[_nd+i]; + + _res_evals++; + +} + +//-------------------------------------------------------------------------- +void Omu_IntSDIRK::jac(int stage, double t, const VECP y, const VECP yprime, + const VECP par, VECP res) +{ + + int i, j, n; + double row_sum; + + // form vectors of independent variables + + for (i = 0; i < _nd; i++) { + _cx[i] = par[i]; + _cxp[i] = 0.0; + } + for (i = 0; i < _n; i++) { + _cx[_nd + i] = y[i]; + _cxp[_nd + i] = yprime[i]; + } + for (i = 0; i < _nu; i++) { + _cu[i] = par[_nd + i]; + } + + // evaluate residuals and Jacobians + + _sys->continuous(_kk, t, _cx, _cu, _cxp, _cF, _cFx, _cFu, _cFxp); + + for (i = 0; i < _n; i++) + res[i] = _cF[_nd+i]; + + if(stage > 0) { + + v_set(_cFh,_h*_a[stage-1][stage-1]); + + if(_na > 0) + for(i = 0; i < _n; i++) + if(_x_algebraic[i]) + _cFh[i] = 1.0; + + for(i = 0; i < _n; i++) + for(j = 0; j < _n; j++) + _irk_jac[i][j] = _cFxp[_nd+i][_nd+j] + _cFh[j]*_cFx[_nd+i][_nd+j]; + } + else { + + v_zero(_cFh); + + // yprime and algebraic states + if(stage == 0) { + + if(_na > 0) + for(i = 0; i < _n; i++) + if(_x_algebraic[i]) + _cFh[i] = 1.0; + + for(i = 0; i < _n; i++) + for(j = 0; j < _n; j++) + _irk_jac[i][j] = _cFxp[_nd+i][_nd+j] + _cFh[j]*_cFx[_nd+i][_nd+j]; + } + + // only algebraic states + if(stage == -1) { + if(_na > 0) + for(i = 0; i < _n; i++) + if(_x_algebraic[i]) + _cFh[i] = 1.0; + for(i = 0; i < _n; i++) + for(j = 0; j < _n; j++) + _irk_jac[i][j] = _cFh[j]*_cFx[_nd+i][_nd+j]; + for(i = 0; i < _n; i++) + _irk_jac[i][i] += 1.0e-8; + } + + // only yprime + if(stage == -2) { + if(_na > 0) + for(i = 0; i < _n; i++) + if(_x_algebraic[i]) + _cFh[i] = 1.0; + for(i = 0; i < _n; i++) + for(j = 0; j < _n; j++) + _irk_jac[i][j] = _cFxp[_nd+i][_nd+j]; + for(i = 0; i < _n; i++) + _irk_jac[i][i] += 1.0e-8; + } + + // error evaluation + if(stage == -3) { + v_set(_cFh,_h*_gamma0); + + if(_na > 0) + for(i = 0; i < _n; i++) + if(_x_algebraic[i]) + _cFh[i] = 0.0; + + for(i = 0; i < _n; i++) + if(_x_algebraic[i]) + for(j = 0; j < _n; j++) + _irk_jac[i][j] = _cFxp[_nd+i][_nd+j] + _cFh[j]*_cFx[_nd+i][_nd+j]; + + if(_na > 0) + for(i = 0; i < _n; i++) + if(_x_algebraic[i]) + _irk_jac[i][i] = 1.0-8; + } + } + + _res_evals++; + _jac_evals++; + +} + +//-------------------------------------------------------------------------- +void Omu_IntSDIRK::init_yprime(int k, double t, const VECP y, const VECP u, + VECP yprime) +{ + + bool ok; + int i, j, l, m, n; + double cur_err, old_err; + + m_resize(_Sh,_n,_n); + + for(i = 0; i < _nd; i++) + _cxp[i] = 0.0; + for(i = 0; i < _n; i++) + if(!_x_algebraic[i]) + _cxp[_nd+i] = yprime[i]; + else + _cxp[_nd+i] = 0.0; + + if(_output > 2) { + cout << "initial values for yprime at time: " << _t << endl; + cout << "newton method" << endl; + }; + + // modified Newton's method + for(i = 0; i < _maxiters; i++ ) { + + _recalc_jac = false; + ok = false; + + if((i % _modnewtonsteps) == 0) + _recalc_jac = true; + + if(i > 0) { + cur_err = 0.0; + // check for convergence + for(ok = true, j = 0 ; j < _n; j++) + if(!_x_algebraic[j]) { + ok = ok && (fabs(_cF[_nd+j])<0.1*_atol); + cur_err = max(cur_err,fabs(_cF[_nd+j])); + cur_err = max(cur_err,fabs(_cF[_nd+j])); + } + + if(cur_err > old_err) { + // damped step and recalculate jacobian + _recalc_jac = true; + for(j = 0; j < _n; j++) + if(!_x_algebraic[j]) + _cxp[_nd+j] += 0.2*_irk_delta[j]; + } + else { + // full step + for(j = 0; j < _n; j++) + if(!_x_algebraic[j]) + _cxp[_nd+j] += _irk_delta[j]; + if(cur_err/old_err > 0.3) + _recalc_jac = true; + } + old_err = cur_err; + } + + if(_output > 2) + cout << " iter: " << i << " res: " << cur_err << endl; + + if(ok) + break; + else if (i == _maxiters-1) + error(E_INTERN, + "Omu_IntSDIRK::init_yprime Newton method failed to converge"); + + + // (re)calculate and factorize Jacobian + if(_recalc_jac) { + _sys->continuous(k, t, y, u, _cxp, _cF, _cFx, _cFu, _cFxp); + if(i == 0) { + old_err = 0.0; + // check for convergence + for(ok = true, j = 0 ; j < _n; j++) + if(!_x_algebraic[j]) { + ok = ok && (fabs(_cF[_nd+j])<0.1*_atol); + old_err = max(old_err,fabs(_cF[_nd+j])); + } + old_err++; + } + + m_move(_cFxp,_nd,_nd,_n,_n,_Sh,0,0); + for(j = 0; j < _n; j++) + if(_x_algebraic[j]) + _Sh[j][j] = 1.0; + LUfactor(_Sh, _ppivot); + } + else + _sys->continuous(k, t, y, u, _cxp, _cF); + + v_move(_cF,_nd,_n,_irk_res,0); + sv_mlt(-1.0,_irk_res,_irk_res); + LUsolve(_Sh, _ppivot, _irk_res, _irk_delta); + } + + for(j = 0; j < _n; j++) + yprime[j] = _cxp[_nd+j]; + +} + + + + + + + + + + + + diff --git a/omu/Omu_IntSDIRK.h b/omu/Omu_IntSDIRK.h new file mode 100644 index 0000000..28dba6c --- /dev/null +++ b/omu/Omu_IntSDIRK.h @@ -0,0 +1,161 @@ +/* + * Omu_IntSDIRK.h -- + * -- class for integrating an Ode over a stage + * -- using implicit Runge Kutta method (Radau IIa - 3. order) + * + * hl, 03/08/00 + */ + +/* + Copyright (C) 2000 Hartmut Linke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Omu_IntSDIRK_H +#define Omu_IntSDIRK_H + +#include "Omu_Integrator.h" + +//-------------------------------------------------------------------------- +class Omu_IntSDIRK: public Omu_Integrator { + + public: + + Omu_IntSDIRK(); + ~Omu_IntSDIRK(); + + char *name() {return "SDIRK";} + + // interface routine from Omu_Integrator + void solve(int kk, Real tstart, Real tend, + const Omu_States &x, const Omu_Vector &u, + Omu_Program *sys, VECP xt, + MATP Sx, MATP Su); + + void init_stage(int k, const Omu_States &x, const Omu_Vector &u, + bool sa); + + void init_yprime(int , double ,const VECP ,const VECP , VECP ); + void jac(int ,double ,const VECP ,const VECP , const VECP , VECP ); + void res(double ,const VECP ,const VECP , const VECP , VECP); + void realloc(); + void init_method(); + void init_yprime_pred(MATP ); + void solve_stage(int , VECP , VECP ); + void solve_final(VECP , VECP ); + void sensitivity(); + + private: + + bool _recalc_jac; + bool _stiffly_accurate; + bool _sens_at_once; + + int _output; + int _n_splitt_tape_eval; + short _tag; + + // backing store sys and current stage + Omu_Program *_sys; + + int _mu; // upper semi-bandwidth + int _ml; // lower semi-bandwidth + int _na; // number of algebraic states + int _nod; // number of over determining equations + + double _t; + + int _irk_stages; + int _maxiters; + int _modnewtonsteps; + int _newtonsteps; + int _nsteps; + + MATP _irk_jac; + MATP _irk_jacf; + + PERM *_ppivot; + + IVECP _x_algebraic; + + VECP _irk_delta; + VECP _irk_res; + VECP _irk_y; + VECP _irk_yprime; + + VECP _par; + VECP _y; + VECP _y0; + VECP _yprime0; + VECP _yprime1; + VECP _yprime2; + + MATP _yprime; + + // parameters of irk method + + double _gamma0; + VECP _b; + VECP _b_err; + VECP _c; + MATP _a; + MATP _a_pred; + + // stepsize selection + double _hinit; + double _h_new; + double _h; + VECP _err; + + + + // vectors and matrices for low level _sys->continuous callback + VECP _cx; + VECP _cu; + VECP _cxp; + VECP _cF; + VECP _cFh; + MATP _cFx; + MATP _cFxh; + MATP _cFu; + MATP _cFxp; + + // sensitivity equations + MATP _Sxd; + MATP _Sxd0; + MATP _Sxx; + MATP _Sxx0; + MATP _Sxu; + MATP _Sxu0; + MATP _SF; + MATP _Sh; + PERM *_Spivot; + + short **_nz; // sparsity pattern + + + MATP _U; + MATP _Z; + +}; + +#endif + + + + + diff --git a/omu/Omu_Integrator.C b/omu/Omu_Integrator.C new file mode 100644 index 0000000..e82a744 --- /dev/null +++ b/omu/Omu_Integrator.C @@ -0,0 +1,91 @@ +/* + * Omu_Integrator.C -- + * -- class definition + * + * rf, 10/2/96 + */ + +/* + Copyright (C) 1997--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include "Omu_Integrator.h" + +#include +#include +#include + +IF_BASE_DEFINE(Omu_Integrator); + +//-------------------------------------------------------------------------- +Omu_Integrator::Omu_Integrator() +{ + _kk = 0; + _nxt = 0; + _nd = 0; + _nv = 0; + _nx = 0; + _nu = 0; + _sa = false; + _serr = false; + _n = 0; + _m = 0; + _stepsize = 0.0; + _rtol = 1e-8; + _atol = 1e-8; + _res_evals = 0; + _sen_evals = 0; + _jac_evals = 0; + _ifList.append(new If_Bool("prg_int_serr", &_serr)); + _ifList.append(new If_Float("prg_int_stepsize", &_stepsize)); + _ifList.append(new If_Float("prg_int_rtol", &_rtol)); + _ifList.append(new If_Float("prg_int_atol", &_atol)); + _ifList.append(new If_Int("prg_int_res_evals", &_res_evals)); + _ifList.append(new If_Int("prg_int_sen_evals", &_sen_evals)); + _ifList.append(new If_Int("prg_int_jac_evals", &_jac_evals)); +} + +//-------------------------------------------------------------------------- +Omu_Integrator::~Omu_Integrator() +{ +} + +//-------------------------------------------------------------------------- +void Omu_Integrator::init_stage(int k, + const Omu_States &x, const Omu_Vector &u, + bool sa) +{ + _nxt = x->dim; + _nd = x.nd; + _nv = x.nv; + _nx = _nxt - _nv; + _nu = u->dim; + _sa = sa; + + _n = _nxt - _nd; // number of states for integration + _m = _nd + _nu; // number of parameters for integration +} + +//-------------------------------------------------------------------------- +void Omu_Integrator::init_sample(int kk, double tstart, double tend) +{ + _kk = kk; +} + + +//========================================================================== diff --git a/omu/Omu_Integrator.h b/omu/Omu_Integrator.h new file mode 100644 index 0000000..c5defe4 --- /dev/null +++ b/omu/Omu_Integrator.h @@ -0,0 +1,114 @@ +/* + * Omu_Integrator.h -- + * -- abstract base class + * -- integrate system equations over a discrete stage + * + * rf, 10/2/96 + * E. Arnold 2000-03-29 _rtol, _atol + */ + +/* + Copyright (C) 1997--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Omu_Integrator_H +#define Omu_Integrator_H + +#include +#include +#include + +#include "Omu_Program.h" +#include "Omu_Vars.h" + +IF_BASE_DECLARE(Omu_Integrator); + +//-------------------------------------------------------------------------- +class Omu_Integrator { + + public: + + Omu_Integrator(); + virtual ~Omu_Integrator(); + + virtual void init_stage(int k, + const Omu_States &x, const Omu_Vector &u, + bool sa = false); + virtual void init_sample(int kk, double tstart, double tend); + virtual void solve(int kk, double tstart, double tend, + const Omu_States &x, const Omu_Vector &u, + Omu_Program *sys, VECP xt, + MATP Sx = MNULL, MATP Su = MNULL) = 0; + + virtual char *name() = 0; + + protected: + + int _kk; + int _nxt; // number of continuous-time variables + int _nd; // number of discrete-time states + int _nv; // number of expansion variables + int _nx; // number of states treated by optimizer (nx=nxt-nv) + int _nu; // number of control parameters + bool _sa; + + /** + * Boolean to indicate if sensitivities should be considered + * in error test (default: false). + */ + bool _serr; + + /** + * Number of continuous states during integration (nxt-nd), + * i.e. total number minus discrete states. + */ + int _n; + + /** + * Number of parameters during integration (nd+nu), + * i.e. discrete-time states and controls + */ + int _m; + + If_List _ifList; + + /** + * Constant stepsize to be taken by integator. + * For stepsize>0, an integrator takes ceil((tend-tstart)/stepsize) + * equidistant steps in the sampling interval [tstart,tend]. + * Default: 0.0, i.e. integrator chooses own stepsize. + */ + double _stepsize; + + /** + * Relative integration error (only for variable stepsize). + */ + double _rtol; + + /** + * Absolute integration error (only for variable stepsize). + */ + double _atol; + + int _res_evals; // number of residual evaluations + int _sen_evals; // number of sensitivity evaluations + int _jac_evals; // number of Jacobian evaluations +}; + +#endif + diff --git a/omu/Omu_Program.C b/omu/Omu_Program.C new file mode 100644 index 0000000..0c5472c --- /dev/null +++ b/omu/Omu_Program.C @@ -0,0 +1,280 @@ +/* + * Omu_Program.C -- + * -- class definition + * + * rf, 16/1/97 + */ + +/* + Copyright (C) 1997--2001 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include + +#include + +#include "Omu_Program.h" + +#include +#include +#include + +IF_BASE_DEFINE(Omu_Program); + +//-------------------------------------------------------------------------- +Omu_Program::Omu_Program() +{ + _K = 0; + _KK = 0; + _ks = iv_get(1); + _ts = v_get(1); + + ad_alloc(1, 1); + _has_low_level_continuous = true; // assume it was overloaded + + _ifList.append(new If_Int("prg_K", &_K)); + _ifList.append(new If_Int("prg_KK", &_KK)); + _ifList.append(new If_IntVec("prg_ks", &_ks)); + _ifList.append(new If_RealVec("prg_ts", &_ts)); +} + +//-------------------------------------------------------------------------- +Omu_Program::~Omu_Program() +{ + ad_free(); + v_free(_ts); + iv_free(_ks); +} + +//-------------------------------------------------------------------------- +bool Omu_Program::has_low_level_continuous() +{ + return _has_low_level_continuous; +} + +//-------------------------------------------------------------------------- +void Omu_Program::ad_alloc(int m, int n) +{ + _Z = m_get(m, n); + _U = m_get(m, m); + m_ident(_U); + + _max_ndep = m; + _max_nindep = n; +} + +//-------------------------------------------------------------------------- +void Omu_Program::ad_realloc(int ndep, int nindep) +{ + if (ndep > _max_ndep || nindep > _max_nindep) { + ad_free(); + ad_alloc(ndep, nindep); + } +} + +//-------------------------------------------------------------------------- +void Omu_Program::ad_free() +{ + m_free(_Z); + m_free(_U); +} + +//-------------------------------------------------------------------------- +void Omu_Program::setup_stages() +{ + setup_stages(_ks, _ts); +} + +//-------------------------------------------------------------------------- +void Omu_Program::setup_stages(IVECP ks, VECP ts) +{ + // default problem without stages + iv_zero(iv_resize(ks, 1)); + v_zero(v_resize(ts, 1)); +} + +//-------------------------------------------------------------------------- +void Omu_Program::consistic(int kk, double t, + const adoublev &x, const adoublev &u, + adoublev &xt) +{ + xt = x; +} + +//-------------------------------------------------------------------------- +void Omu_Program::consistic(int kk, double t, + const Omu_Vector &x, const Omu_Vector &u, + VECP xt, MATP xtx, MATP xtu) +{ + int i, j; + int nxt = x->dim; + int nu = u->dim; + int ndep = nxt; + int nindep = nxt + nu; + bool grds; + double *Zi; + + ad_realloc(ndep, nindep); + + adoublev ax(nxt); + adoublev au(nu); + adoublev axt(nxt); + + for (i = 0; i < nxt; i++) { + axt[i] = 0.0; + } + + if ((MAT *)xtx != MNULL && (MAT *)xtu != MNULL) { + grds = true; + trace_on(4, 1); // tape 4, keep result for subsequent reverse call + } + else + grds = false; + + ax <<= x->ve; + au <<= u->ve; + + consistic(kk, t, ax, au, axt); + + axt >>= xt->ve; + + if (grds) { + trace_off(); + + reverse(4, ndep, nindep, 0, ndep, _U->me, _Z->me); + + for (i = 0; i < nxt; i++) { + Zi = _Z[i]; + for (j = 0; j < nxt; j++) + xtx[i][j] = Zi[j]; + + for (j = 0; j < nu; j++) + xtu[i][j] = Zi[nxt+j]; + } + } +} + +//-------------------------------------------------------------------------- +void Omu_Program::continuous(int kk, double t, + const adoublev &x, const adoublev &u, + const adoublev &xp, adoublev &F) +{ + // empty default implementation +} + +//-------------------------------------------------------------------------- +void Omu_Program::continuous(int kk, double t, + const VECP x, const VECP u, + const VECP xp, VECP F, + MATP Fx, MATP Fu, MATP Fxp) +{ + _has_low_level_continuous = false; // i.e. not overloaded + + int i, j; + int nxt = x->dim; + int nu = u->dim; + int ndep = nxt; + int nindep = 2*nxt + nu; + double *Zi; + bool grds; + + ad_realloc(ndep, nindep); + + adoublev ax(nxt); + adoublev au(nu); + adoublev axp(nxt); + adoublev aF(nxt); + + for (i = 0; i < nxt; i++) { + aF[i] = 0.0; + } + axp <<= xp->ve; // initialize without ADOL-C trace + + if ((MAT *)Fx != MNULL && (MAT *)Fu != MNULL) { + grds = true; + trace_on(4, 1); // tape 4, keep result for subsequent reverse call + } + else + grds = false; + + ax <<= x->ve; + au <<= u->ve; + if ((MAT *)Fxp != MNULL) + axp <<= xp->ve; + else + nindep -= nxt; + + continuous(kk, t, ax, au, axp, aF); + + aF >>= F->ve; + + if (grds) { + trace_off(); + + reverse(4, ndep, nindep, 0, ndep, _U->me, _Z->me); + + for (i = 0; i < nxt; i++) { + Zi = _Z[i]; + for (j = 0; j < nxt; j++) + Fx[i][j] = Zi[j]; + + for (j = 0; j < nu; j++) + Fu[i][j] = Zi[nxt+j]; + } + + if ((MAT *)Fxp != MNULL) { + for (i = 0; i < nxt; i++) { + Zi = _Z[i]; + for (j = 0; j < nxt; j++) + Fxp[i][j] = Zi[nxt+nu+j]; + } + } + } +} + +//-------------------------------------------------------------------------- +void Omu_Program::init_simulation(int k, + Omu_Vector &x, Omu_Vector &u) +{ + if (k == 0) + v_copy(x.initial, x); + v_copy(u.initial, u); +} + +//-------------------------------------------------------------------------- +void Omu_Program::stages_alloc(IVECP ks, VECP ts, int K, int sps, + double t0, double tf) +{ + int i, KK = K * sps; + + assert(tf >= t0 && K >= 0 && sps >= 0); + + v_resize(ts, KK + 1); + for (i = 0; i <= KK; i++) + ts[i] = t0 + (double)i * (tf - t0) / (double)KK; + + iv_resize(ks, K + 1); + for (i = 0; i <= K; i++) + ks[i] = i * sps; + + _K = K; + _KK = KK; +} + + +//========================================================================= diff --git a/omu/Omu_Program.h b/omu/Omu_Program.h new file mode 100644 index 0000000..db6b592 --- /dev/null +++ b/omu/Omu_Program.h @@ -0,0 +1,191 @@ +/* + * Omu_Program.h -- + * -- declare an interface for a multistage optimization problem + * described by differential and algebraic equations + * + * rf, 16/1/97 + */ + +/* + Copyright (C) 1997--2001 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Omu_Program_H +#define Omu_Program_H + +#include +#include +#include + +#include + +IF_BASE_DECLARE(Omu_Program); + +//-------------------------------------------------------------------------- +class Omu_Program { + + public: + + Omu_Program(); + virtual ~Omu_Program(); + + // + // method interface + // + + /** + * Setup stages and time sampling. + */ + virtual void setup_stages(); + + /** + * Routine called by default implementation of + * public setup_stages() + */ + virtual void setup_stages(IVECP ks, VECP ts); + + virtual void setup(int k, + Omu_Vector &x, Omu_Vector &u, Omu_Vector &c) = 0; + + virtual void init_simulation(int k, + Omu_Vector &x, Omu_Vector &u); + + virtual void update(int kk, + const adoublev &x, const adoublev &u, + adoublev &f, adouble &f0, adoublev &c) = 0; + + /** + * High-level consistic (consistent initial conditions) routine + * for the initialization of continuous-time states from + * optimization variables x and u. + * The routine is called via the default low-level version + * before the first call to continuous in each sample period. + * The default implementation copies x to xt. + */ + virtual void consistic(int kk, double t, + const adoublev &x, const adoublev &u, + adoublev &xt); + + /** + * Low-level consistic (consistent initial conditions) routine + * for the user specification of derivative information. + * The default implementation calls the high-level version + * and uses ADOL-C for the determination of xtx and xtu. + * If a calling routine passes no xtx and xtu (or null pointers), + * then no Jacobians are calculated at all. + * If a calling routine passes xtx and xtu, then the matrices are + * initialized with zeros. + */ + virtual void consistic(int kk, double t, + const Omu_Vector &x, const Omu_Vector &u, + VECP xt, MATP xtx = MNULL, MATP xtu = MNULL); + + /** + * High-level continuous routine for specifying differential equations + * of the form F(x,u,\dot{x})=0. + * The default implementation is empty to indicate that no differential + * equations are used. + */ + virtual void continuous(int kk, double t, + const adoublev &x, const adoublev &u, + const adoublev &xp, adoublev &F); + + /** + * Low-level continuous routine, + * which may be implemented in addition to high-level continuous + * by a derived class to provide Jacobians for differential equations. + * The default implementation calls the high-level continuous() + * and employs ADOL-C for automatic Jacobian calculation. + * If a calling routine passes no Fxp (or a null pointer), + * then only Fx and Fu are calculated. + * If a calling routine passes no Fx, Fu, and Fxp (or null pointers), + * then no Jacobians are calculated at all. + * If a calling routine passes Fx, Fu, or Fxp, then the matrices are + * initialized with zeros. + */ + virtual void continuous(int kk, double t, + const VECP x, const VECP u, + const VECP xp, VECP F, + MATP Fx = MNULL, MATP Fu = MNULL, + MATP Fxp = MNULL); + + /** + * This routine is intended for a calling module, + * which might want to avoid calling the low-level continuous + * if it is not overridden (e.g. as it has then a faster sensitivity + * calculation). + * @return true if low-level continuous is overloaded + * (currently low-level continuous must have been called once before + * false may be returned) + */ + bool has_low_level_continuous(); + + // + // member access routines + // + + const IVECP ks() {return _ks;} + const VECP ts() {return _ts;} + int ks(int k) {return _ks[k];} + Real ts(int kk) {return _ts[kk];} + + // + // textual name of a problem definition + // + + virtual char *name() = 0; + + protected: + + // + // provide a container to keep track of interface elements + // + + If_List _ifList; + + // + // predefined basic variables + // + + int _K; // number of stages + int _KK; // number of sample periods over all stages + + // + // service routines + // + + void stages_alloc(IVECP ks, VECP ts, int K, int sps, + double t0 = 0.0, double tf = 1.0); + +private: + IVECP _ks; // starting indices of stages + VECP _ts; // time steps + + void ad_alloc(int ndep, int nindep); + void ad_realloc(int ndep, int nindep); + void ad_free(); + + int _max_ndep; + int _max_nindep; + MATP _U; + MATP _Z; + + bool _has_low_level_continuous; +}; + +#endif diff --git a/omu/Omu_Vars.C b/omu/Omu_Vars.C new file mode 100644 index 0000000..8169020 --- /dev/null +++ b/omu/Omu_Vars.C @@ -0,0 +1,94 @@ +/* + * Omu_Vars.C + * -- class definitions + * + * rf, 2/3/97 + */ + +/* + Copyright (C) 1997--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include "Omu_Vars.h" + +//-------------------------------------------------------------------------- +Omu_Vars::Omu_Vars() +{ + c_alloc = false; + c_expand = false; +} + +//-------------------------------------------------------------------------- +void Omu_Vars::alloc(int n, int n_expand) +{ + n_expand = max(n, n_expand); + + if (!c_alloc) + error(E_OVERWRITE, "Omu_Vars::alloc"); + + if (!c_expand && n_expand > n) + error(E_RANGE, "Omu_Vars::alloc_expanded"); + + v_resize(_v, n_expand); + v_resize(initial, n_expand); + v_resize(min, n_expand); + v_resize(max, n_expand); + + v_set(_v, 0.0); + v_set(initial, 0.0); + v_set(min, -Inf); + v_set(max, Inf); +} + +const int Omu_States::Discrete = 1; +const int Omu_States::Algebraic = 2; + +//-------------------------------------------------------------------------- +Omu_States::Omu_States() +{ + nd = -1; // must be determined + na = 0; + nv = 0; + D = v_resize(v_get(1), 0); + D_is_const = false; + flags = iv_resize(iv_get(1), 0); + sbw_u = -1; + sbw_l = -1; +} + +//-------------------------------------------------------------------------- +Omu_States::~Omu_States() +{ + iv_free(flags); + v_free(D); +} + +//-------------------------------------------------------------------------- +void Omu_States::alloc(int n, int n_expand) +{ + n_expand = max(n, n_expand); + Omu_Vars::alloc(n, n_expand); + nv = n_expand - n; + v_resize(D, n_expand); + v_zero(D); + iv_resize(flags, n_expand); + iv_zero(flags); +} + + +//========================================================================== diff --git a/omu/Omu_Vars.h b/omu/Omu_Vars.h new file mode 100644 index 0000000..b63f115 --- /dev/null +++ b/omu/Omu_Vars.h @@ -0,0 +1,78 @@ +/* + * Omu_Vars.h -- + * -- Omu_Vector with capabilities + * + * rf, 2/3/97 + */ + +/* + Copyright (C) 1997--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Omu_Vars_H +#define Omu_Vars_H + +#include "Omu_Vector.h" + +//-------------------------------------------------------------------------- +class Omu_Vars: public Omu_Vector { + public: + bool c_alloc; + bool c_expand; + + Omu_Vars(); + + void alloc(int n, int n_expand = -1); +}; + +//-------------------------------------------------------------------------- +class Omu_States: public Omu_Vars { + public: + int nd; // number of discrete-time states + int na; // number of algebraic states + int nv; // number of expansion variables + VECP D; // diagonal of dF/dxp + bool D_is_const; // F can be treated as explicit ODE + int sbw_u; // upper semi-bandwidth of dF/dx + dF/dxp + int sbw_l; // lower semi-bandwidth of dF/dx + dF/dxp + + /** + * Define flagbits to characterize individual states. + * This makes nd and nv obsolete. They should not be accessed + * anymore as they will be removed in a later version. + */ + IVECP flags; + + /** + * Indicate a discrete-time state, which is not defined with F. + */ + static const int Discrete; + + /** + * Indicate an algebraic state, which is defined with F, + * but whose time derivative does not appear. + */ + static const int Algebraic; + + Omu_States(); + ~Omu_States(); + + void alloc(int n, int n_expand = -1); +}; + +#endif diff --git a/omu/Omu_Vector.C b/omu/Omu_Vector.C new file mode 100644 index 0000000..1938888 --- /dev/null +++ b/omu/Omu_Vector.C @@ -0,0 +1,86 @@ +/* + * Omu_Vector.C + * -- class definition + * + * rf, 2/3/97 + */ + +/* + Copyright (C) 1997--2000 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include "Omu_Vector.h" + +//-------------------------------------------------------------------------- +Omu_Vector::Omu_Vector() +{ + _v = v_resize(v_get(1), 0); + min = v_resize(v_get(1), 0); + max = v_resize(v_get(1), 0); + initial = v_resize(v_get(1), 0); +} + +//-------------------------------------------------------------------------- +Omu_Vector::Omu_Vector(const Omu_Vector &cv) + : VECP() +{ + _v = v_copy(cv._v, VNULL); + min = v_copy(cv.min, VNULL); + max = v_copy(cv.max, VNULL); + initial = v_copy(cv.initial, VNULL); +} + +//-------------------------------------------------------------------------- +Omu_Vector &Omu_Vector::operator=(const Omu_Vector &cv) +{ + v_copy(cv._v, _v); + v_copy(cv.min, min); + v_copy(cv.max, max); + v_copy(cv.initial, initial); + + return *this; +} + +//-------------------------------------------------------------------------- +Omu_Vector::~Omu_Vector() +{ + v_free(initial); + v_free(max); + v_free(min); + v_free(_v); +} + +//-------------------------------------------------------------------------- +void Omu_Vector::alloc(int n, int n_expand) +{ + if (n_expand < n) + n_expand = n; + + v_resize(_v, n_expand); + v_resize(initial, n_expand); + v_resize(min, n); + v_resize(max, n); + + v_set(_v, 0.0); + v_set(initial, 0.0); + v_set(min, -Inf); + v_set(max, Inf); +} + + +//========================================================================== diff --git a/omu/Omu_Vector.h b/omu/Omu_Vector.h new file mode 100644 index 0000000..757d400 --- /dev/null +++ b/omu/Omu_Vector.h @@ -0,0 +1,59 @@ +/* + * Omu_Vector.h -- + * -- variable vector for Omuses problem setup + * + * rf, 2/3/97 + */ + +/* + Copyright (C) 1997--1998 Ruediger Franke + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; + version 2 of the License. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library (file COPYING.LIB); + if not, write to the Free Software Foundation, Inc., + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#ifndef Omu_Vector_H +#define Omu_Vector_H + +#include +#include + +#define Inf HUGE_VAL + +//-------------------------------------------------------------------------- +class Omu_Vector: public VECP { + // base class holds variable values + public: + VECP min; // minimal permitted values (default: -Inf) + VECP max; // maximal permitted values (default: +Inf) + VECP initial; // initial values (default: 0.0) + + Omu_Vector(); + virtual ~Omu_Vector(); + + virtual void alloc(int n, int n_expand = -1); + // -- allocate vectors of size n_expand + // for min, max, initial, and this + // -- (default n_expand: n) + // -- derived classes may overload alloc() to restrict + // the capability of allocations for specific vectors + + private: + // dismiss copy constructor and operator= + Omu_Vector(const Omu_Vector &); + Omu_Vector &operator=(const Omu_Vector &); +}; + +#endif diff --git a/rksuite/details.doc b/rksuite/details.doc new file mode 100644 index 0000000..0b57020 --- /dev/null +++ b/rksuite/details.doc @@ -0,0 +1,421 @@ +*********************** Organization of details.doc *************************** + + In this file, details.doc, DETAILS are provided about how the codes are + organized. Included are: + (1) The ordering of the subroutines in the file rksuite.for. + (2) For each subroutine, there is a brief description, a list of the + subroutines it calls, and a list of subroutines that call it directly. + (3) A description of the labeled COMMON blocks used for communication + throughout RKSUITE. + (4) Details of the usage of these COMMON blocks, including which routines + initialize, read, or alter variables in each block. + +******************************************************************************* + + (1) Ordering of the subroutines: + + All 26 routines are provided in the one file rksuite.for. They are ordered to + ensure that linking the suite is efficient on your computer. This order is: + + SETUP + UT + STAT + GLBERR + CT + INTRP + RESET + MCONST + ENVIRN + CONST + FORMI + EVALI + RKMSG + RKSIT + TRUERR + STEP + STEPA + STEPB + STIFF + STIFFA + STIFFB + STIFFC + STIFFD + DOTPRD + SOFTFL + CHKFL + +******************************************************************************* + + (2) Brief subroutine descriptions and subroutine calls: + +========= the SETUP routine==================================== + + SETUP - setup routine for the integrators UT and CT + + calls: MCONST, CONST, RKSIT, RKMSG + called by: none + +========= the UT routine ====================================== + + UT - computes solution of ODE system at specified points + + calls: CT, INTRP, RESET, RKSIT, RKMSG, CHKFL + called by: none + +========= user-callable routines (for use with UT and CT) ===== + + STAT - provides statisical information + + calls: RKSIT, RKMSG + called by: none + + GLBERR - provides global error assessment information + + calls: RKSIT, RKMSG + called by: none + +========= the CT routine ====================================== + + CT - computes solution of ODE system for a single step + + calls: STEP, STIFF, TRUERR, RKSIT, RKMSG + called by: UT + +========= user-callable routines (for use with CT) ============ + + INTRP - interpolation routine + + calls: FORMI, EVALI, RKSIT, RKMSG + called by: UT + + RESET - resets end of integration range + + calls: RKSIT, RKMSG + called by: UT + +========= local machine-dependent constant routine ============ + + MCONST - sets local machine-dependent constants + + calls: ENVIRN + called by: SETUP + +========= machine-dependent quantities routine ================ + + ENVIRN - returns machine-dependent quantities + + calls: none + called by: MCONST + +========= auxiliary routines ================================== + + CONST - initialises coefficients for formula pairs + + calls: none + called by: SETUP + + FORMI - computes coefficients of interpolants + + calls: none + called by: INTRP + + EVALI - evaluates interpolants + + calls: none + called by: INTRP + + RKMSG - handles setting of error flag and printing of messages + + calls: SOFTFL, CHKFL, RKSIT + called by: SETUP, UT, CT, RESET, INTRP, STAT, GLBERR + + RKSIT - monitors the current situation of the integrator + + calls: none + called by: SETUP, UT, CT, STAT, GLBERR, RESET, INTRP, RKMSG + + TRUERR - computes root-mean-squared running assessment of error + + calls: STEP + called by: CT + + STEP - takes a step with the Runge-Kutta method selected and + estimates the local error + + calls: STEPA, STEPB + called by: CT, TRUERR + + STEPA - part of scheme for selecting the initial step size + + calls: none + called by: STEP + + STEPB - additional estimate of the local error for METHOD = 2 + + calls: none + called by: STEP + + STIFF - does inexpensive tests for stiffness to decide if expensive + test is necessary + + calls: STIFFA + called by: CT + + STIFFA - does expensive test for stiffness + + calls: STIFFB, STIFFC, STIFFD, DOTPRD + called by: STIFF + + STIFFB - determines dominance of single real eigenvalue (stiff check) + + calls: none + called by: STIFFA + + STIFFC - computes the roots of a quadratic carefully (stiff check) + + calls: none + called by: STIFFA + + STIFFD - estimates product of Jacobian times a vector (stiff check) + + calls: DOTPRD + called by: STIFFA + + DOTPRD - computes weighted Euclidean dot (inner) product + + calls: none + called by: STIFFA, STIFFD + + SOFTFL - soft fail routine for catastrophic errors + + calls: none + called by: RKMSG + + CHKFL - soft fail check routine + + calls: none + called by: UT, RKMSG + +******************************************************************************* + + (3) Description of the COMMON blocks used for communication throughout + the suite. + +C .. Common Block to hold Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ + +TSTRT - the initial point of the range of integration +TND - the end point of the range of integration +DIR - the direction of integration as determined from TSTRT and TND +HSTRT - the initial step size to be used. When input as 0.0D0, the + initial step size is calculated by the code. +TOLR - the relative error tolerance specified for the problem +NEQN - the number of equations + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ + +T - the current value of the independent variable +H - the next step size to be attempted from T +TOLD - the previous value of the independent variable +HOLD - the step size taken to advance from TOLD to T +NFCN - a counter for the number of function evaluations made in the + primary integration. After a return to report a considerable + amount of work, it is reset to 0. +SVNFCN - a counter used to account for resetting NFCN to 0. The total + number of function evaluations made in the primary integration + is SVNFCN + NFCN. +OKSTP - the number of successful steps taken in the integration, excluding + those made in getting on scale for the first step +FLSTP - the number of failed steps in the integration, excluding those made + in getting on scale for the first step +FIRST - a flag to indicate the first step +LAST - a flag to indicate the last step + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +C .. Common Block for General Workspace Pointers .. + INTEGER PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + COMMON /RKCOM3/ PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + SAVE /RKCOM3/ + +Pointer to the first location in the workspace vector of: + +PRTHRS - the THRESHolds of the local error control +PRERST - the estimated local errors +PRWT - the weights of the local error control +PRYOLD - the solution components at TOLD +PRSCR - scratch storage (holds the derivatives at TOLD) +PRY - the solution components at T +PRYP - the derivatives at T +PRSTGS - the stages of the RK method +PRINTP - workspace for interpolation (for use in UT) + +LNINTP - length of workspace provided for interpolation (for use in UT) + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +C .. Common Block to hold Formula Definitions .. + DOUBLE PRECISION A(13,13), B(13), C(13), BHAT(13), R(11,6), E(7) + INTEGER PTR(13), NSTAGE, METHD, MINTP + LOGICAL INTP + COMMON /RKCOM4/ A, B, C, BHAT, R, E, PTR, NSTAGE, METHD, MINTP, INTP + SAVE /RKCOM4/ + +METHD - the Runge-Kutta method selected +A, B, C, BHAT - coefficients that define the method +R - extra coefficients for METHD=2 for use in interpolation +E - extra coefficients for METHD=2 for additional local error estimate +PTR - pointers to where individual stages of the RK method are stored in + the workspace +NSTAGE - the number of stages associated with the method +INTP - indicates whether interpolation is possible for the method +MINTP - the degree of the interpolating polynomial, if one exists + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ + +TOOSML - a quantity for determining the minimum step size for the METHD +COST - the number of function evaluations required for a METHD +SAFETY - the "optimal" step size is reduced by a SAFETY factor +EXPON - the reciprocal of the higher order of the pair of Runge-Kutta + formulas that constitute a METHD +STBRAD, +TANANG - the radius and tangent of the angle made with the real axis by a + sector in the complex plane that approximates the stability region +RS, RS1, +RS2,RS3, +RS4 - bounds used to control the increase/decrease of step size +ORDER - the lower order of the pair of Runge-Kutta formulas that + constitute a METHD +LSTSTG - pointer to where the last stage is stored (for use with FSAL) +MAXTRY - a bound on the number of iterations used by the stiffness checker + that depends on the cost of taking a step for a given METHD +NSEC - the number of steps in the secondary integration that are + equivalent to one step in the primary integration +FSAL - indicates for a METHD whether the last stage of a successful + step can be used as the first stage of the next step + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +C .. Common Block for Global Error Assessment .. + DOUBLE PRECISION MAXERR, LOCMAX + INTEGER GNFCN, PRZSTG, PRZY, PRZYP, PRZERS, PRZERR, PRZYNU + LOGICAL ERASON, ERASFL + COMMON /RKCOM6/ MAXERR, LOCMAX, GNFCN, PRZSTG, PRZY, PRZYP, + & PRZERS, PRZERR, PRZYNU, ERASON, ERASFL + SAVE /RKCOM6/ + +MAXERR - the maximum contribution to any component of the global error + assessment +LOCMAX - the position in the integration range of MAXERR +GNFCN - the number of function evaluations used for global error assessment +PRZSTG - pointer to where stages for the secondary integration are held +PRZY - pointer to solution components of the secondary integration +PRZYP - pointer to derivatives of the secondary integration +PRZERS - pointer to the error estimates of the secondary integration +PRZERR - pointer to the global error assessment +PRZYNU - pointer to scratch vector of workspace for secondary integration +ERASON - indicates whether global error assessment was requested +ERASFL - indicates whether global assessment broke down + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, OUTCH + SAVE /RKCOM7/ + +MCHEPS - the largest positive machine number such that + 1.0D+0 + MACHEPS = 1.0D+0 +DWARF - the smallest positive machine number +RNDOFF - 10*MCHEPS +SQRRMC - the square root of MCHEPS +CBRRMC - the cube root of MCHEPS +TINY - the square root of DWARF +OUTCH - the standard output channel + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +C .. Common Block for Integrator Options .. + LOGICAL MSG, UTASK + COMMON /RKCOM8/ MSG, UTASK + SAVE /RKCOM8/ + +MSG - indicates whether error messages have been requested +UTASK - indicates whether use of CT or UT has been specified + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ + +REC - holds the error message + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +Details of where COMMON blocks are used. + + I - one or more variables in the COMMON block is `I'nitialised + + R - one or more variables in the COMMON block is `R'ead + + A - one or more variables in the COMMON block is `A'ltered + +* indicates a user-callable routine +? indicates the routines for use by someone enforcing/detecting soft failure + + + RKCOM1 RKCOM2 RKCOM3 RKCOM4 RKCOM5 RKCOM6 RKCOM7 RKCOM8 RKCOM9 + CONST I - - I - - - R - +* CT - R - - R A - R - - R - - R A - R - - R A I - - + DOTPRD + ENVIRN + EVALI - R - - R - + FORMI - R A - R - - +* GLBERR - R - - R - - R - - R - I - - +? CHKFL + INTRP - R - - R - - R - - R - I - - + MCONST I - - +* RESET - R A - R - - R - - R - - R - I - - + RKMSG - R - - R - - R A + RKSIT + SETUP I - - I - - I - - - R - - R - I - - - R - I - - I - - +? SOFTFL +* STAT - R - - R - - R - - R - I - - + STEP - R - - R A - R - - R - - - A + STEPA - R - - R - - R - + STEPB - R - + STIFF - R - - R A - R - - R - I - A + STIFFA - R - - R - - R - + STIFFB + STIFFC + STIFFD - R - - A - + TRUERR - R - - R - - - A - R - +* UT - R A - R - - R - - R - - R - - R - - R - I - - + +*************************** End of details.doc ******************************** diff --git a/rksuite/f90.uu b/rksuite/f90.uu new file mode 100644 index 0000000..3b1d641 --- /dev/null +++ b/rksuite/f90.uu @@ -0,0 +1,1460 @@ +From: Richard Brankin +Date: Fri, 16 Sep 1994 14:52:00 +0000 (BST) + +begin 644 rksuite_90_v1.0.tar.gz +M'XL("%Z/>2X``W)K[_B.%3B!QRR;^Y[]&?,^AC#=UZZJXQ*BE%FRBLO%4;I\?7SN__"K[/C_ +M;S]^_?R^@^!$__/`M1S7QV?;<3SGD_]_CU>O_Q?%W)[7Q=RZGSW(_W#Q,?]S +MR_>E_U$!//IL>Y;'/V/WM/WMKS^Y_S\_FUUD^:Q:L<'G@\_9/^.R9L62[<." +M45BPX;/=);.CR!V!2+^J8EE?QV7*ED7)LCRKLWC-KN+U+F7;LKA8IYL*PPP1 +M50GFSW;UJBBKQ^RGZ;^F[*LRSE]C>OB/9]^R[^O%=,Q^?`M.BS%[GE^NXWQA +M[L6^F[)OU_'B.EVO&1O^$-)=76SB.F67:9Z6<9T5 +M.9FD2N)U7&+--LT7:5Y#TS*+H2467Z5EI<@,RRW+8L-B9B]87);Q3<]2O5!( +M`+&_?,ZR)7L@)Q^PK&)Y`;E7*5MD55UF +M%[LZ74#%[0V)\V`OS_0BKAYHNQ!]F5:[=5TQJUYAATH: +M1^VU2>-<6.H"Z]*XGBWCJIZERV669-!N-IU.]3:KXCJ%CF.6P=I%6K'KHGQ] +M!NX59)RD[$$U.Q_.7Y;)J_.1/3NWK=D#=CZ@E7)R;B]F'0+(?;` +M/-&7XVJR:; +MEW'VZN7;_!42<3*YC;+:;8X2V(+B?)@4F\U?;EYN7STZ'TV&<-!LA"6#3_[_ +M_^+_6_L_OY\>0IO1&S`G]*5L-#%>RUD3:0+:#23.*$+!+G-UE^ +M:2K]Q^DK\_)\^-*:<%3MV3S!V:736<@O<\Q(Q\YGG0[2-`"BFRFJ_CZSSO*4 +M,/7LJ8Q_O"/&_GTY%%>C+F<3A0^OTF3.9]=I=KFJ*QRRU$(:'>V''PP^CO][ +MZ_\F?IW.R]?W56-NK_^V9;O.OOYS%_7?#:Q/^/]W>37U_U/Y5^6?@M\TP'6& +MO7;5#LJ)0H[,K*$&D@C+0)]@%,U"%3)!#6%8L:6BB1)XA3V:PB?+/&U1OB82 +M9@JJ7]]0PN4<-*1PFXB\5ZOBBN$I%9ZQ%Y"P^=D=D@V15 +M9$GZ]*$]2.(J90_E-9(33:FT1LR\Z=QN&>Q+XWH964^>#,ACMRYY9\"8ON6E +MC>7)EG66]6UDRXTT)CI!MI(;LO'3U+E]R5WJP*\C-E"NOLV05IUNM@\?WDW: +MVC'I+.LQG'W`^)C!DD/2HX;BIY*VQ>TL4VCLKX1ZT&CK&*#GS5_!0ZG%OEQF +M>7N):"?4.>BFP*.N%/J38IVS-N\Q+E`LZ>,6VSS,V)=?LF8+PT]YVE@TKMM$ +M7WS!P&)2+"=9OMW5]F!`4^4R1LY4:;W;TLI-L=BM1:=+TL6N5#/STA[K3U;S +MB>M/23.;-+,)'V`WUFQA;(86>9G.Z?H2YY"T=]L.C1#@8`R;_=?><,;K@)(? +MKH;0IRTFG0[&CFM7U>GV#N7:)-*XG:&CJG4)^<%:\L9):X6S.D.WZ87S4E5G +M275$)SVM]-E?6NU+?ER\ABAILTC:+&Z1\G)=7.#XDY8E@$R?G":!D+0]8'4' +MCDK;(DNZC)(NH]OR(47*S.LYYOMS83\O\\"\MCK71^4UJ9(.EZ3#Y19AQ:=M +ML3X6V\:\$+9U;76NCPIK4B4=+DF'RVTQ"XVJNMC.BWR^C.MX?:S$M:ETN>N. +M'D_*0UK>Q^&6U#RDM7HYW!+Z1!Q?I8M;5.W0R`3HCAU5\X"2'ZX6*K*3EHL< +MZ8X=UR\IUFL<4N:7<7D17_9'7X=&Z'^3W"/HD.HKM^T!UZ!- +MHYAMK@Q&;8BJ2)_:[D[Q+^#OCW0-EBG59P,Q)5U&`*?_/_'\7_O_;\V +MP/^/[S%9EN6[[I'[?XYC!YYY_X^>__.QX-/]O]_C=1!A\VV9)H.SP=DI-P// +M]FGQ'C<#B?G[WPS<[_7>-P.-I7?>##P3C?22[J-LXS+>I"A`[/%C=KUE3[&: +MBA1ZL/CJ`!(OAK8U]JS1H#]=I3$'AVG\9[;OKCHPT9@5^?KF\?461^W-=ITE +M:!PY5TIKP=\V&C&/'.:1J07O#]K2F+68 +M'*#.`Y@V4';T>TOAZS>EZL +M%_0FN-,'(>TB*P^:K7R=87VZ/3MDMAJSE62VTLQ6<\A?0MLCO(XSJXNUSAZZ +M7$*E70Z.R]UZ/6^NA(_4YXMX,=]?#];%998@L+$X)A\HB6)]Z.M8H_T('Q*V +M$/X6HJS@1RBGOD`;LYM-_+91H%IM)T*%D_E5"0(J`<,;_$/DWK<==: +M-<*GNH758>S$0]L9VP[X7`S%6R+?+E9Q+3^50]L>^_B0#H.1&6?;NI04>3$O +MEG.Y^9A2"M5[52Q$&2BW\P6J0IJ:02;'Z1L539.GZ:)2+/IRKRBJS9KJ0D61 +M'"_3&@&1OMT6N:@B%]DZJV_F9;S(=A"ACO,Y2M2Z*3XER571386*[K15#OUQ +M3650E*GWH,#64HPQZNE;?,R6RSE*)G&0>J+R4>I4ID++"C7G4&R0$A.JQ65V +MT:/6O$UQ+//[JH`A.YBH+#\Y[+`DKJJTZ@V6#\A3\+L9B[];^?;A>8K5K?SZ +MCS)".*L_*51&&%Y$]:THH.A]V>?/3;*"X[$A(,$2(023+Q`2^%B]*D9]V4%1J[NRJ-BGA]');GFKLN*FKUZ]KUN.%;R]6PS+R1QLMRRTRZRY +M&7@8^:I(H]";!D]6KU-RUG855RD?[!'G7M)`+"4D07%34S$R&'1`AWE?"+M) +M,-H+*\1W(V?O]7W&/7\[<:]?!]S+/?A[NT5^3_>M[^F.\D>XUWO/=U3O^0;F +MT1M&ZH;0V:!"443YRW(ZHR0KO%/#J^KAOH"J^JG*IZR>8U$R1W_J0UNGI)*9 +M\WH(P\B6<&H#.E@INU'/66*QVVQNNMNV3N3U*BL73V'\^?5VYH@W("[T*=L2 +M%^`JN./<[M,.6D9<@^H1&FBV1J45&XT&4FXZX[\IZV%[_0:`P7#H!(+H[T"&(P)]'8!;__==GJ9 +M^'=\!^J]C<^)L/%T\Y>JS4'69+>N;IUY3,N4M3B8>%-L7 +MH9%XO4>[LJ8S"%_3@VC;.2GIL33SU_N`9[ +M-3U%M]]-I`F)C>,GH&"<"X#%Z/9C"A!>TU/M]+@>:04MR51FR$)Y]XEP#3Y- +MZW*73I](I^-:?#'3A!`&PFD$ZSXY"#>BG3ID>$IB$9H8LJ:AH-['N[&'F2D8 +M=@9->3>3@18LXW5%*]IA)M8(=40J/G9'&!G.F`4C"KLZ;#:2!/&0C^V1<+/H +ML3)NY(PC9ZS6$**B-2IU]V/%GTF+-C7&G +MU\N)R1H\90'AG8+!C]>+G#W7EFY5"T2")^O(J?7B)^J:+(PF'$$MRX9NI*BI +M\%'.?A!5#7DOF?R29^+'.-09FCZ;OJ4WM-J^\M*M+)+/!Y87U@A/ZDA6F@_P +M896^V6')^H9.0=DRHY@V@ARAF.8K'=\(T76FJ@Q"4#(S=B(=BC*[S'*4KF6Q +M*P$S9)AJ?A!:Y`W$C7.F;W^U>*T+NA$ASKU@^9W\T1"5%[8DN#$6U_3P]JZ6 +MOQT"3\#V32=CAM5:;*Q-K2)*YE9%"\=%31CXJE809I+PE-:^X5ZL+_?8KM*NS-> +M+#*2E7[PA5-NTQZ5EN(IBFH'137'"U00O0N%E7S26YHB7[.+*914Y``^M$P@.2D[R*00^'5#7Y;(VKM.T>I@'H6(R/[T91\0&.DH +M;(6K1;$7RC`'4C06G6XRV2-N83C,$,C-\EV!/MHJTY!",D-2+-8I?2];ZKS` +M5B@BRF%0QM@+\D-S>4]'!H;DHD@@:3\."(_B`+>+`[PI/X8#'`$13L4!Q[M^ +M/TSP]W(;0(";0"`\``)C!I@+<.6/67`4%/B'H$#U>1X<@@.W9TJA`SM4/<5V +M`GX($2:VK_@Z;@].L"VO?[DGN?NAVCD*6I.2MQ++MEMS$H"H7>W6KMY8=KO( +MMY10H6\N]N6N7J1[-O=XV)H7&X>Z0WN\-2EV]ATKDKAGYH5>T%DO]O="7ZOM +M^+X56BT23\COVUH&RVT1!,KN@6MK,2,OXJ[;HI$&@BC:$$$4.4&+Q)&J>-Q6 +M$S,P=%W7B5ID0F+?]VW+5U26$]FAW2(2,D\X=M/(([+\L$7B"[5"4D>!$!O4 +MYEZALGZHQ`DMWVU-\RYV#96S7==RE-@SVW,AGMLF$TIPUVFBC<.H;1*A@J/W +M=@_FA?S<5BZ?>5'HM>8#@?6XKWWB-GX]`G_[L6\#/]TVBN1N$.E$BJ)]W"DL +M:1D#,K.XQGJV;\Q);]KPE(YAU[8#;BZ7\:<-Y;KFG#0"5ZDZ\STC?2Z&T@1- +MH"$Q;82**:NH5@Z/%'?/\R//O\U*S_=6:J.:`S1P$5,/+7(!\QLP>/TI93&)2V`(1=AHZ]NB(>X +M,UCN$H&&!')X3DZCI<_)9M1^?TO+0CD\E0Z?-*%JI'_:]78JO=TX8N8[W.'F +MO"N9:8=RRPSL5'J;N\9FYJPO:[@N,\9,8,AQRE'$-\:=WF.E.HHH20)CW#/H +M'6/BM,3BOJDX;&N`B53)$@$B +MI]IWT9%3HVV)DGSH0]M$$Y$1!_$PDG7<]?0RN]6<;$O.3T(G",,0D1G8G@8! +M=N!'8>AC*&RML>6:*`SLR`H<[NN`]3QT1X?-`OO*.QV6B[:HM_1X +MY'F.S]N;RGVDX0OWT.\;.`#&$>_LZ4BH$CK4.[Q("QYXD>VC +MPV&@L[=L:1BV?-_SHJ8E!1:Z;N`Y'!6]HZML;_3_\.HR8`=18'.K(XN@"STB +M#%W/<72W1N/W/?1FF"((?*LMCU@4A#ST(M>QN!/J/A1R.^0>=H$1.@))/-"( +M#CNY75D\:6+?]EW+@^S:B@",/N("/=:#3P$3+.`YKJ[BP(T +MV8,!N-YR.R+((A4&EL4!@WPM01!Y(?V'NJ'MMT60/&%J.]2X#Y%G'9C>J'6S +M=FA92"Y"_]M",^RX"IP4*P20RNX?= +M<::L+!/;%<^26QH2`#($MD^)9387.NGH&B#'GV`,1YK'?CO-0:B="USK.D[H +M-)PM#[TO,N.;J#U]3+&`J#G7T-VRG-#KD,I6*@`YQ8B.+A0ESXP`(I59#^]& +M(2%)2[/EJ!%N&':HU5')1J!RA+..6\>SN!_M8UN9PE$:PFY1X,!^?E.F4`@+% +MP;`H"/QV2;@Z)D!+G#1\6V,2%PGM^ZX.5Z6GJ_3DPH11A)+0U*L(!T>'*JC! +MWU6:!F&$^N"YR+F@*2HX5:"&^6[+\JY6%KR0]D`_&F1[?H!SCA]VR)TF6.`6 +MQ_5\KK&NB\!R'(!TWEFB=(9QO(A"S->G0_$3"L_W]I!+Z>TIO:F=J`/2#`L= +M`TD3D0I<2,E1PK08*$].6P1UZ)U`O$"KQVV[2R15H^J&\JO=B%[!PPZA.EKZ +M:&"VSH'0=\.];94>OJK"-LI+%*+M-H'D4+@$!E=UZJ76C/*'LJIH85\7DFI*ZF>^TZ91*CA=0_W'T+0%@"$1'&+:)I5H^DC#TT4>57A', +M;FM*I5?0M(_0TJE*QSV#G3X1`ZT@#314\5N9IH[6(IJ\YCB&CM@F4DJ$'JK# +M,49*=@3,X5Y*:'6`Q<%7HS+78*&/O\CYWEDAJ?N_[/W;Q60B0DH4P1;("4S*J_]KZ= +MN[F8BWF)N9B+N9R8F$>9!YF(GN^TC@!(RG9EG:SN2I,@L+#6M[[UG0]:3O-^ +M97F^WZY^EF6I3:6>;SD_6E*DFJDP;R4]]JS[1;#8[CC7&!W:[HTLG^FSYOS& +M,X*)#-N:O6B9`"A3N[VYI2C9-I`%V&4;5Y3P4KH7J"-BFG>O<`V;0P)E!W+F +MW2>TI;.)9+?=[VBZB[1NR[];+&!=X,%=H'>*[,(1`";FXJN67YPAA/,!5W2O +M,C0[V^[5'MO%W(L,1TVTV7?4\WQ'O5K?T:OT^B8\(8WY\/8R&:(SK<+AG(@# +MZ0&&FM4/K=-6^!Q+G6$>Q0^M\`#4LI;M>8ZVV>6\M;VQS0[G#MO$ +MQ0U5[19"CY#S&O42I4+!,AP/D?@?5O="=WK&_*P\OLK^O(WWV_9G085*`S3; +MIO&))09H?@O>N-CO[)F@VV;R=2;H#B&';8/ND!FZ:UNBHW`G"G?AI[))NM_J +M+_C;2C;4"FU3]4ZO_L]]@K!TJ]7MVY?%>MUK=?SK);U1N/YNJ[?MW-IWANA8 +MUTM#*.[::75`L=WN6S^(^]6[OJ7&=E^Y51Y:N)Q[20;=V78F)DRVTW*NBCUY +ML[6]VVFC\%WY9\]BNSR+[?(LMO720$T"E@LB7_EOQYV)F)$!'T"OV>Y5/8&/ +MV%-AKM8"&7%K!X2LJK]=^PG-(+BB#J$X"!W8?J#,[ +M5YB8>P!SD%:[^!]0)7L@[?6[P)?[(.Z"SF6O5K'<5A]$H=[6+C)X4#JZ*+V" +M4@C3W@(MT)V)+!:T1>`S:#[O;X'\OM7NH+C:1S5\N^N^8UOP#A17$%=`SP8! +MJPVBT\XV2-^[7>!"H'_:CXCQ9JNUV][M;X-4!6+>+JKG(.'UMS9!;@*-Q@%0 +MA:EEMPR@726%MGJ;:,O>W@*]\1`1%H\OTVNC]`40.VW(<7@?J#>DH'Z8/]Q#:?;A"V +MNSM;J(["BT"DALD`=P5-`B1O]X$=)D&=#O8^`KZ^@T(>,):=?K^W#9(U0-J9 +ME#)XP8'LH<4;QNSMMC?[L!\(3=B_;@^>]!ZILE^5H&K$B]8F0F2G#6I7IX_^ +M()!%-O'S-HH:]@/JD.V"NK.U`_@*ZP`IIK_50[VTBRZK]J8W&5'$6B#$@-0- +M\X63@DV?X'E8.HCWFUL.3BC[1K>UL[E-V`;P1TUB_8#Y6WH5&R#$IM:6X#6H%%O@78$ +MAWX;E3$$)V`$J-*),Y4^XQWL$*X-T`RDP^U=F`6Z +M[B/*JMSIX=+Q!,'"0=!%E;@'.P[G?6O+/-!57!^V:JN-"-3#I[J`6/!&6#(` +MV3MRW8J-ZU9L7%?.#[`_1*+^-IW)+HK?W1[`!C1%4%6=@?OR`"JQ/>28VX!M +M@#:[FYM8,!7%]XXW%['7M-J;NYLHN'2!3G=A*X#$(M;!.=SJ.0]LBURT3?8$ +M4,M`*T1[S#8*_+`=OZL*-K/'N]G9Z,'_4:0#`L-/.!K2%Z.T"UP`,@LUM;X%FL@5\'8[T9A<( +MFC,CY1_HH7J$9[,/N[N)^`>(V$6["9`>!TPBV^VT`#1=I%I`A/MMP&_$#3@< +M77C#=L][I+S+O8I=5D8M$$:V:+%(Y4`=(QQ"VWY3TBSBI`"=CM +M3;31[;9)^@'<`$`#Q70)1T^LN+`7.-HN^E@!-&T`UA:P%0#3#B#`MOV`T,G= +MW3:L`E[4!A1'CKB#QIUMD%&`+SG[T)8W`*O>V4*U'U`;W@`[#[P*:#U0@7YI +M\V3#MQ']^G@HMG>!Q.,6PD%"TKJSZS]B[]ZO%R2Z\P6#1+>5EYX"ZEF0AE.* +M9Z*#N-X&B:7;Q3W9)1'5$N?I$=]YC]=Z%=RN@R1:LI(>,TMHY>F2'\1P.3:<- +M!P,=%N0;(J:$3&7'?V)7G280Y&`R0+DW-]$`O0L2!*@'6X`O.WWO&<;#+>!> +MZ&4#.@^0!":_V4'3\3;ZHX`#^,\(&L*Y`XD2_5-M`$$/_7?P6GP`Q&7_F:[" +M]YT.D.0>VO.![\%2-I$3P[.PD5O^0^+%5I-V@C5:Z%3L=I!6@VBW"0(["(G` +MYX`Z=[H6^&N"-^P+_LZ7MEWV'.@F+`V(+;P&2";P).3;(-D`B=YRMH,W'/36 +M3A>$WG8;F1W2@FW4!P"P_ +M53H8M!W`!1!MCO#D)L&\`/&-7! +M77.N2]G<[1:RD3X3XBZ(JZ3"O[SS0U<%):RZ5[=85!L.1=W>2EHO@>2 +MT4$73I_T/N0).Z`M;7:W[/O5D70&X6W9;0&MPWI0V^C1A;.#Y`/U+9!105QP +M'K`B0^0*P8A^4;EWE-%BV,(PN:)4+JS.#>07ZS*C>0V#2&\3ILXJOF$0CP:S +MD8H^Q@&.]\_.+\[.L8KW!EOFLB*UHY,QXT<%+6-,/YK%*)1:TOMPD-.S3@3_ +MZ>)_>OB?3:RP!I.ZG=V2G?`V_DB?F?VH>.Q"PG5I/1*C<7!R=BXSP00G6I`. +M9'Z]_WN8Z]&+%Q='YX>G9W+?>'9[F5#0,^8AR1LF27Z;3B4FB;*4QEB489A, +MS;M"@E_.Q:OC:7B++_SOB#;AU6S,44D`L1&-9@9O^?.0L5(>'MX[1D!)B$GX +MW]?]:?\6$.O_J.`KJY0Q^NV0+8D(M0[>6?$PL&DR&H]26&+APD#&\>:/D=_Q +M`(.,X^LQ;#`ABH$*\/7N)AF1#W__]N0-%O<>A$*HTL2$9%LNA>ZT[,M`;8!5Y.&SP%DV[L1'"]T8E`A&IP +M-MHZCKE.N69-3HI%:,'M`+*G#9*`GL!'L?B'%,*D#Q^`@^'&L>EQ4_SAH'#4!]`>-'YK_(QS1/M[`OL%K6YC" +M0#_OT<^TA?%X'AYA>HX,E6`D/&[]#Y1D,`^+FVPV&N)K;^,A)H0F@Q3.YESN +MO)R39?]ZC'9\%.XH89"7'&#,&!(N-P\29D?U#-6="$O^$N%G("H-2MJ++XM& +M8]!(FQOPGR>=9\[F-YM6PNQM7'S8J[WUZ5Z[V0QY.S$`/Z`=G-YGWV+&H^Q. +M7N"W+B)$L;[>A7MZ_!DNXB^;^KY>1;*SE=),Q2:IJ-@*+`5D9@K+C[@\`U>9B525*ZEV\L^=$UR= +M,"N9P5)33/:B"LC\5UD-K#28VKO%95[/@;"C(ZI7C65\P#4)\+7%4/.AD +M#!?Y&+[LK9T=GK][NU95C>$&R$\]"CP`,0B>=N8TY3-C8M"8Z@!.\PO81T.C +M[*HWH^0Z'DV]Q72::KT=M>!.;1%'H.:XL\/Y'O"]D.J0[(%^'868''4!8F&R +MUUF86XVL98\E>"S!T.[@EPY]\].NB3!5UJBHR\>V:E=$I;SLE#RZ>I[?$KQ0 +MG6"6>3!*XAQYT%V*`;M4,TCGM2%1(PZ$LBZ36BE=4TQGL!7CV6B47LVYVZ^J +MG$=?O`)S=$V7U./FP%S%[E]8<(`+NE*>N317]T[T0^/D7E_D$?AAJ0=`7[B6 +MEQE&JGJISU5ST^7$K"'X7/QM/A6[8Q;DX9&,X55&#Q2G08_ +M2X$5N4YU:JJ9(=VA2]A<9L/Y,^;VB#8WR>`#<0>N^USHI)RV&[U'O.CT/;^*"SB'0@_$U)O>2<"^IU%J/::V9=U,A:ERX +M7!+QU7RR8(%;1%6&BH*$R6F>WB&'U]0USJ]G*-(5"DP3+-\$1!AID+MLHDHH +M4<&_&-[0_)8W0U=8D]_@GKUP[70M;&$^K;F2JS4PY4.]UGV<'[">."N-4:Q9 +M6]4"$+5XL$_?GPC^[ZF]2^^S&6B_!;)UI[ +MW%J+U"!'4UUC7.RBCT\?1X]S^-_98^Q8][AX_*`]]79'ZE@XRQ9V@9(V?:(] +MDM^<.AARH_J-:F&L':]%:Z,UM:>Z5`:*]M9] +M:+Z(9\`&?ZV=P_"KD^=F[_C[\MT[AIT;P?]>P_]NX7^O>!=OENZBV&L6["2+ +M[DTAN';U0MI*%I;P3/.11GJ:@N(\'E!71,Z",4='JM?E2+5>>RO#WX=/@&X_C@^/.U:*UF26*'4+R+ +M*TG*-+]5UV3V2D%Q'X"M,C^I1ZIOQJ+)>R$JZ@VL)4`OV9#[FF4L;&A5)OR. +M),`F4USK^F]#EW9B:`B\8*2`HM<=7&6N2)(FL1"KW-%3N(*0"R5,/` +M"VO^5"_5;QX,W>50C>G\L%$/69@YG$P,C0V)#,$*=@:N8L"+UAPIK0[K+5'D +M+#$)I[:Y&L^V)LZFOB5+CW;U.)>%B&@:R[^7\N]`?:>R5!J#DVJFZ +MXE;NHDMN?3EO)+MLEW7!K3DG,Z(:7=[SJF073X?K=BEEP2O>Q1CG%UTV:U*W +M4#TO^=35GWKZTZ9\DIH5WC!V42^Z4*KL9<')E**CBU2/SAI/%::#S[[JB[PL +M_HAG0VU`H_NLM`/-IM9)N#BUDA+U>7W*^O8WDAEZ=G[X]N+HS?GAR]-]ZCFI +MN#X9JZRJ=@]OX&I!O-DS"5[ILRRM-TO>_/VO(MZ8B,MI.BC)Z%+Z" +MV^06+A6CGDZI1)=W-UOXAY2P"A*D_>FYF\'[1YOPR7HK&QL3U)N!9X!Q4NO +M<:B,OQ6W,'@DL$`=UQH(>&F68\T=F)IUF81,WFFIF`1TC+H<<.T<[KN>#K0C +M1)?]68@"!'8\!&2DHD/3L.FM=3;6\3>TGBO^'O$7%'_X()$B0TTPVSJVCOA:5KX.\@9BC'2-F/'07 +MPFP!N]<6[X+*_:2Q#7G-K6[ +M_V(++N8UY$^J&GZ/?W/0@F\0-"R__:GF-?3**HGI1E'P&R.LVL+!_HC+1Z"W +M2[MR2:DII+"1%#@O)*0HE@=L^QX;=Y2#I4-.HSH9"Z0L&N*;P+Y6M@^N.&;M +M8&)8?-#4:@KIJ&RW3N-RB9C+/9]0T6SZ?N-KHSN]7% +M'5MF%Q.NV?Z?LS1/I*(X%2E;3>'!Q*FYHWA2ZQFF5LJP$-I/\(E$+4GK0-\Z +M(U(/B[WO'%Q48T]8UW5_M)^^:^M?G=/ZK6797OA\Q_S*^/$LTI;,NV[YQV[3 +M>;Q7OJ/7]&G:VSS94&1*;U"I*`DB!?(K,B;NA;^H6K4/MH:?)O4DM<5(!H&<:"H(BE4-V*X9TJ77I>$?]N@-> +M=1+=B9*?8C5ZL7PP]H"L=,*K!JL]W^:.O_Y!-SOHV2GEJA97*KY7.QF.6'I- +MBT1\="B456*^78@P9*<6VN\DEI#-7%[7'L>^94M0MCM9B5'<9`:>L7]T3@_? +M(9O#=@F9'\A_&FRZV"0KK1R`1F4JXWQN1U&W5+:LN9.E4:!'$_J40C^Z`O\V9[1T-)>W;)DHAJPLT;F#+<*JOPV4*GFBG*/F`E1'<7]K@&.DO@4. +M2?,2#KGCS^+^SS_<%M<8`X?A,!R2$U%0#+X#;82F`W(I4.NUFCOF@:7NE+;A^LO3:/9MHV[JE2M*'Y`5:]I^H'>+)0 +M]]LP4,"T>-J>#^@K]WW,H_9TT0'#VZY&[JL@>U4$;.F@[*J1YPL&G?OCS1^$4)E%9<;=FX@RU&$8F +MK-`:<1$2\@T^#E9>U6,WORTOL!.)*4;^[7$F1[APD@LF9KVL;A9+X,#G9>$; +M*H^4OKYD?*W(+GB!W%-^@_RPY!6KHF;IUO(+/01=`KI%IY=_KP#:4LQ&)7#!H:?%V+I(GK%0TB`Q`FI[E17J7V#>6>Y1R +M%LI5-+VXC\>8?G*=83(*_7>8Y.D=?5S0EL[_NQK%U__<\M"25!.$\W(P+DXU +M4?W2:+L^>;#*+!(U-.-`:)!`#V:WPG8><_,R$!&J94,+)J9C'8N*NB\JXIO. +M5+QJ`#8J(S/F&QJ4NIA0+@4:T)YQ7FP8AHMW8&5P50ZV,(NG:K!5AF)+`]H8 +M"')U\U)#X?$WP/&:P:Z<`N/%2-0FPV!BU#B[KYE4/?B<=M*@5")"1'8"#*EY +M=M;+-2AD@P]1"'HH]G9>+;5E5J`=9&^CZV2Y`"&-BVF>36X2N-`5"F;GONC$ +M)+?3*M`$I3A&(:84BG:Z8JK,PO057E]H%0[DE9HK7L["48&Q*792+)I[T(+B +M;=Y_8ULYV]GWK`;$=`7IO&0\1;Z6K:,)Z.O>'L&PP@MI`73U\-]]Z[%T(`9^ +M#!.*1[2!X662C"7S.AF2(8K,W`O#!MWY:F3X_&!E'9M"$2<44!02U+"O03B' +M7P?Q&']#$N1'&*TP8V,BKW'6/2"@LVK:,F4_+"N^0C3%Z6OO(451X3&?YV+1"`X(ZI'YO,\!-`CBE`"#`->`$GID$Y\5CKH4CTLNJ\&%J +M1GXOR6"K`1=]U_;2T/)E&;ND[<]ZP>D.,&A+8FM$O,)P7PJ^2HL*!&EQ5S;8 +M_M.W%_O?'V/8=>O%_O'9(9%'`I"J7'N"(>^/7SV.5"X8%A.X1#LN!LB)JTF_ +MX?SBI_TWYY@[3CWA*?>=)B+EA/CW%DQ413IRB.!EZ3*AUGMK+@BK.V@GK87@<3ZF,@VJSI^ZE/8"Y4+3C(0#D@F;8 +MG!O430MQ(>J@S?`<2WK`Y.&F`0C'17@#;/TJ9M>A5PB*SP/7B<)03!#.AT5I +M"PD8C")FSRET4NW[Y=P-;(C*.X=^R@FN@`(>W%7@6`T*J1R,LL)4M/(FP;'I +M]*SV2C+$"#0:TA*KPG*S>U4XK@H3?%!@+AP%"4_%((W)".0PBD6%U;VRCE+X +M2M7#LL-?&;$71KW:CE;'X;%7"LI3"[^1H@H8BL,75`0HHLZ&O?*F%;^Q0F!I +M71T""0)T1HZL*R;RU)^F>MF-B10,K5B"4%Q4[)9`Q])<5,U0K%ML=2GVK*&3JZ +M@-SB[=9C6=LN.@DG`+B*1RK)V?PR*DQELC%DI+7HU>NC-U9NXB)N"!SPIX3! +M$;L<4`K$>:%X7E=$F9VT.J?@/=)>[J4?M=9SU)&NT(>6*B,G?F87O_LVGI)6 +M4^CFT'H+1EBPBW+2/H*PROK997:7N-*40?.22FF$.`KGP0DSW5=5K0B)S6W: +MSF7T?X[3T!$4!H/AS7Q[<\5J%F\E!9S%Z2@<@FH`F'M_DTA"%Z7Z:8W?+]_\#N54M8Z/WUWV++0"3X6]XDT8ZG5NJXL(1`\SK$L^CY/N2FL[##\"+):C!?TJQ$P79G&^'LFMEHK29 +MQ#7J-I1X==FT038&*_R7+6=RK/>TDOP]-K%]3S0.XVK?/S\\/?J1O[)2.`YM +MW!AE\5`9H$CAS48S#MM5R($O]6QS]?LLQ0];055C6AVB.T4=`:9/M&JO#1.,58`0G(-26V8`MB=C&FT2$5$:V"DCHT" +M[G]S\I.<*9HA?T*@(U3G\CVTO(!.@T: +M#L?:\[:\&3&<8PTI5"B94V.1<9_JFXP*)/2ZO +M%2C+#YE.T>>D7=V&*HVS^[*#6SNHM-A%3K:;%;(#$2Z73B%; +MWH8I][T6O*%1L'RO/J)6U9U&Z?6A5,JA[*/Y8)0H5N7]WFT^5(_2YD)51H8L +M5GDVG`VH%;@E:'C+0G!K(:J48'TT-M?V3;X]8=,D3RG_8Z#.[#33`V&]L&O2 +MAXPD]QI-R.A;OL+MU4(D3/D6Z[L@2JB#&]F&%#/"\>-6N.;!JO=LJ[G$K_*7 +MAY,W*57BR/8$LK_1$&!3),AB<$S4ORUK*<-,H\HW7NBUS3X5&_]D<\S^6$>7 +M,R``T7T-`8L0..$GEETK'FL8L5N0J)CD4R,;O@'42<:+-3>N7HMTR.@.5-9)&Y:J0$!+YQ,L.5S<8@PDD+U6JQ7"SFANYUB.">(Z'9D`SN(6.0JX +M2#19_"Q-Z7>OSUY>G';8ECO)KI<C%,_A/!_[7!928 +MC+/\-L*2DWE\#H7Z7,C8[\VXNP3,HM%D(M9GG"]8'^`M$[ +M:$_323']=KL=?;F`GD6E;['R;4<^[\+GW5)I6RZ`:]6WO9F-AU@-M[UJ4=OZ +M2!\7<_Z;7=?B[]0O-%*4K,'WD4Q1Z1V +M:N-X'S.\MRCVR*A.C)LHQ*3C6>):H*0V&,4>N1%+?J22'N\A(4M+0XZLS9Q/ +M$%AB962XSU55#2'G2J-17Y_HPK*E%'V3":`>FEN-T"1SR+2UP=S*;*0R\)D> +M<3TSY5"B$`[^W;$M2<3297*=CJE1"=4OF&K3CRHYCN9DQP;/B?]HYD(E0909 +M=""@=D#H;[+PT9UC_86CDF,"?C8?X&N?12S1/HJ/I?5-7S])%6KP@)@7D/3?H8]X4#Y=D +MZ8G)Q*V\]FE5\#1(=2&\JI,T!GX27V8YF:Y`L[N5?<6NW"2I$%Z0Z2AE$!0S +M`"$\AQ$\J&-A]3H0O]L\..VBD@;7! +M8L-\1M-C\R&HSN%E7"3ZI/#ID2/%>\<=_61!4]-J,%)(I*L,ZD4+4H^R"0DY +MUUQ^-,?"B\;VB`>0:QAJ5'A%U>]HREUTEP,DT!C#$5:,1Z`!\XOB#ZJSD/&* +MM>3A'M>QF_!"MBD.4R@H8!Z<,9#C^(*90RZ,&1"D=<8U%F!E-J&5L@M$4V1H+=PJDAR6*&4)O9J$_)M=A'!J +MEQ?$X1Y685#LK52J<&B]GTL8#D#1YNJFNMHDS%R?;A/H=GB'I341:?G&&6'8 +M4&HANE@8R;9H@LHG%Z&ICFGME#5VD;]SR#9&M(%(BRU-7A#@F&*EN.ME/.1= +M,Z2-=1JO(ITJ?/>MG;$.]_#-WXH"Y)OMJ"`-W5$;FV?%Y9E?62T3NLH$LARD +M@V52#N!3C +M6VV@XQ@D+2+BS\J(:,4:F"P!/D58K,V-(G]X+XKO4;ZR/5*FL1]95^6`LN7! +MVB\N)`RTFDI6."Y\C0=4ZMR.@%6((9U+3IF#*#%.2,D5K`M=/%BJJ41(.+0R +M,R5TQ5W/CLJUXRS[$,8WL%-K2!HQJ(GZWHW5D"EP'"+>YHV%)UXI7')\](+S +M3V0E&]81\!SV2W'2/2;\J@WY8KG(O=A#-8'I?;:^8!*U+[,.K3S7?`IC507< +MW$A(F,+AC*)8T`$I,CAF\:,5GF$(^/**I1%EIV.^=V7Z"^K(%^0<*(*R=*>: +MZ9DFEO'4KC5*7$_Y#72TFC0P>/)*R@HK]FSJ!!>)]1BK:9*)((5L[?JUK%)/ +MG6JUVK]E4./!,64VJ51H4PHKD^L+8LGZ2S5<1;D,!;/H%TC++".BO@E@+Z[F +M[,QA85)*%3&D_,+.Y`M"XF<[^="J$%O'%79?"."K:,TX^#59/(>KRN@`<#*. +M(CJ$1F;C5D5Z"U:-#GN=@3RBJJ_=3M";D&FOOI*;Q8/)33F\_(>*"':NEE-] +MDMQ2/%I:\2X;_=D>U[OK.[1/ABU`YI;/C:MO9[S3!8*>]FJKIG4UTO07N*4= +M1'G-63T@I^&L;/VE8`9(ED,_0L*)N"'^$QD'[MQZT(E%U#&XZ,)39@]-Y\UV +MZ<'*VT8:IQ@SX=(0I>6CJ>`L,E4XO533KW$+.F8SO(7E&8^G=FGC'&A):L5N +MY`>LC%BM'>[1(*.XZ +MJH#I'XN4\DIT%@0$52E#]5W?P:H0U3G$YTG;1*U,?*I>N$5%A")+!G:,GIF( +M^UI+]"5_A6]U^L[V,+CGAQ^HQ??>,N$NW2I)=OLFT`;6NQ99[P:2I5U.PIN( +M7QETEE0A@P5/6+=\?'%VHJ3]2D[-@XA?)V`3B-#/:U)PZ"5`Q@SDKI@-2="98: +MS!%)"^T/82E&[8`4Z,Q(9]983*+0[!HY)DD.%/Y$;:`1H!+0*^'8G-`X2T3O +M-E.P@2'14E@`S@H08(>>\>=Y$;K6#];!>YLGPQ0X(.85TH3)O\C35K(6IB6I +M-#'H:*1G%>X%R*[64AX0+)0^T<;+4[5&96)55U8IR +MDR1ACFTLE,0DLK57X-@2;[&1CLYO!0&'?`T5L9YXJ16>$5/"3(Z8!"C&*DWJ +ME`$1`<9KI:!0,0!:^A(&4BCQN!08:BB=XY:2?YQ2:4K%&D4XY*+.H]Q_5;Q5 +M=L=6#,"@\`[+B.B4CD=1!$<7I@',7(+":8.KME9":W6W,5M-9\(9B4!X+]<*$$B\`S4"9TBB#$M@L/(U/%.@7J[QI)11"^T% +M6LLIO195$2DQ81VQF$P7Z6`VFLZ-Y4YQ"R(*Y:%H1G@V*P!'0%T`*ULRJ/?O +MVF\S)G!5U8:"C]39RPM+%74S$17VNW5GU8/>54>E54]6U:U5SU?^YH^"2W04 +M"`^4]4NI6HW_`/=S4PDVV>@IQMY6&]K=I\F20R%6:RMJ!4\]*^M?EJ!G&V+L4&]E5AF#V*%HC5(GYK+S"-:#],9^B_5;X$YQDYC^D2)#'#C"Y, +MJX6XK5ABS!S*GK!73S4%K=BT55/DIAT9S1Y#":[6;5TM\')AY:K;LL15JH'/Z6!Z*[FU7( +M_A1_9R0IYR7&BD4H=UT]JU">7DJ+<1R#\+*D$.Q;!K4L?85> +M/@17:`L!?&<,"R*0N"+Q%B0 +MK"6CMC8JF%FC.AT99LM>525,XHC"3E'SSA#K*:8!Q"&0O&'X:ZKSGK.1[/2L +MBR<.P$FCJ*0U/&?6(PB!E`8Z/>M1>())B<9<%IR&,!V"CV+LA4REPCBY(!?4 +M\9"6PK8TGY`/C*QT@CR_!__"!%"),7G1]510'J:N4TV9^%73.O\<..W'B&)= +M2S*N)99H%&/95,)$D+6#<#W-TP$+"][1HG(L-E&WC?&*"95O!L&@Z8]4RQX, +MF="R[[?5`!&Y3@BUJ)LI]2K1=@*,X@A%M1;WO\B.M/PH?'6Q_^/AZ?[+PXAM +M%-P76T2AX<.Q1RORQ@UO*%Y%GP+[_LET=]V[^`2C=]?+`UE.WM!VNJDV>%J2 +ML!33S24:W\G"9.+(*.Y9X>NN@6.?9 +MLPH;F<)2%;`S]RDS5R6,*$UVP"X:$81SRG^RT0&-6F^RJ2S=L]D6FO3&=$*$ +MWMVS?NX?KPJAV]ZG*CG/D>[XY')2*"NPLYS*#IC`/ES:%*UN.<:YI'=`-)'Q_\>;PI["!6272AM"J*E;H<)BFMX*YC3MSU=Q,7T`= +MTHV>=.Z?E+$!&^W:*A[Y3U^<[1]KZT84OG^K='2RZ9)FZT0P6G*_O,C`5PJ& +MTS?3$5AW=C/YU`>H7[,=4CRJ\&+7V*C'_M2`4"\GN:9W%%M5"^R"$JD48=%1 +MI5^3?^`HF_3\Y/@Y^9(J#IW3(\HLB,PC($V#PF^,"M@DIF3',E'$.ES5F;V( +M&=36$E/XAJ@*DA"39]BJ>)C=8VFP#'(0V1.61GC\6V?G5SK`&QBSKZ%]-?(# +MJWR"S5$2)5&C@A3"&;(8894TK;'3'$7SD!UM7'K,",EF)=_5]7I;J5-[*66W +M#LTM#3]/1JGNA7O.<2E6=1S'*3Z-UEJEZA0H&%,S7"T&#E=N#U>A":^>A+!H +M@?'H.H/';VX5GL>Z9QEG*.(78_RV>[!]T06NUO]./>](F9*%ZUZK:8\$A^=0 +M5U6@G73MI*22)PP"\1BKN&%QMF+:`.LYI4HE2O:77&#T:_PV]-)_.,71)!C[ +M9TU^]T6,@8E;4`^KAZB/P]P>%IB>E9-H.)L^@=Q%M#*XG'NBA!91M9P#UGES +M"ZI^6UM.=-V. +M1-6`8?$V1_2(ILG69KB"*+5U["0BEP=`^3BFN0!BB +M\/9CDH]@`Z8%;@.W)*%_IR!==?2GKI/PBF2$69=F@1ZS?9ETJ_\]=AW.#\$ +M5B=$:"M,LE3R]TO;@F@.>@OK6[*R]H(R%ITX#$_.`HKIEJ. +M)5C@/28Z0P>-SYEIC:5ISHVZA;S#MONX=*KX0M.LOL*ASA`@IX@;!?OJ`I57 +M.^VJ"@KF<9*B,0A6W)D\D.*VK\X.#P!$-.C3QIN3BY,7%R\/+W`/SIHM4;X) +M7BR$H[&+4Q1S-K*.39U'2C0@@9UT6Q)MK7G&Q?QV,LVFZ0#$\YOX+@6^3L,D +MF!PU5B;STE0YUI*+RL`2:2C71R[F?@`#A@[D%*0BXT0ARE]<<#$6YZ=$?'?\ +M]0(HUM<;)Z?/#T^?`$\T@3C3^ZRR7A89A"FDD0)-*5S\Y)C\VTG*P:99QKF9 +MZ.!WH\<1DAQ8PV&1L1,G2-IPA>-\<`-O&GO!<7[$G9W-8`,*'<9 +MF=J51UN[TQ=$H`A!HZQ[/&+?[:GCZ2OIB@1U+>.6_:"B777/\;\E";%DG>/I5.E^.HO44@5AA][3#?C!,L'YS*B.7F^P4*2H]CH2 +ML4!3K3EEU@LO_21[),];FZ9HEJM;*$.5_VTZ@9?-DZM8)SWH6"-?-31I;Y9: +M\BH(6E\FPU@B=%7T%I\^4&I`'(:IO-[__<7!R9OSTZ/O(VVE +MIJ9P5`*0F,*%>U^+0E#X?)K=A\,)]W#_]M\?GAX?R!)92K9F;[4?_E9D9V,R +M\W\G[IF2@F^E(2*$-N;-IZIG9[CD3V4BZ@H"..1W/#/G3.C)X@VEV5FBB-VX +MP3$C`3XY/E.0RR,G0EHBJH>`@CF&F!49&U2%=3#Y$EYYJVUMDK6+Z=+*Y*98 +MN$)8G@8.1C-A6QO2#>WYEC8FL)O[P%_.SM1AM7&@:L,YHI]0::CI.96C$S\N +MK7#.QEBG$`"&@ZKY,M-4<<`2,0;0_F[B442A2D'HV/@JT(?=8W#AVVKT0:2A +M'?PV-'1$]Q@WGY^$E5BUOMX-G2EI?VBHZYES;.K:,.)VV+.E+ZE;],5L#R`VB,)'I9+W2TT +M)&'%L.I7/[BQI#H9H6..6&&HJ&*P&D/)-V)"^&J^^TN8[Z;%]'KIJFN`8)O= +MHO`/=FVYP6QZ&7^(B(;PWN48\FULA,`7\->/$>5U+\-@R^2D:B.$7)G&FYDV +M.:UNHHL7+!1'67UJEU%X"1P\"JM,H3*6-DC6CC*9YBML`(WR31EN];7O;N+1 +M%7SI>P7OQ$]U>GIX=JX-,DCQ,;Z2RNJ`,HWB.VFCJ5-O&D6..EN9;(^ZS%^# +M6%^(@TO]^3)`N)FO&`HZT%\'`8)$?8//\%;B37N2_S!ML+F+0\W4-Y&&^#-?VA*`1`SAGQX$O+OZUIW`@@U_M"T`T.'*C-? +M+*A`C9X0(UWG023[V:K9K!L(QJ-09:!AB*8G&MMV!Y/[R9DN=G,_%3V)N#-* +M=#4:^R +MA(-&"KHX)HJ880BO^>U5893XR-Y>1NY1'JL4'.:@00I<@]7?Z74D/>J]*+`I +M%ULBZJ,CO1P;#:D"M=8DKBB$T6Z8H$M=S-*9S(LI6?6 +M!1.5P^(>JN4K`X?*FBI4EXY[CKA1@<*T,A:_U%%PZC1QF6])%9G>5-1F$F.< +MZ&YN<2DJEZ[U21=]THG\^7XX_.L+XHF2IDU_3W^ZI +M(&9RHL"PS>^JZFAX5"!N^.>-54J6?YK^"@FT>C(P'1=WF#> +M>-V-*Z]*`..D13$<8$W"V]EM2TJ!X9.1A)'1#F%NHT2:J<)A6XJB+`G'-:`30*![<9?2D2J/SH*F%`)J@5;5/9W!>D/G./68I*G:1B&/ +M4YV);68/#J_/3]NKR82C9;"D`%*+[^07(>@(--J1#\T/@]K4&9-2MF+)"CS(!,$V!"F:)E,7G%,SFY +M8C1-N8HBH`X#0A>/,1CGB:MT+.`TU9V)C?#2G+7E!XV'JS]B.%S-^3*'2S]4 +M4B?.[8,3FT#F@:Y4B^;S)$9VAI[?$7N/J.``JUUVEA=35%7_-@YU.5OM.;,+ +MD^J788"_P1U*77RG'>9.;<_*&<933B^#]18E$4AZ7%%I,H5K:SB+-9VSQ?/. +MLTM`+*H/8C`9'0A"DRL#QUE4UI6ZV==AX")U!5218(J0OU+%E&JH.UX2?T#VD8S4@7#18,<9U,C"3:&[#4R61YF;[1 +M;@&'UVOW@'>5C-8I:BSXG.<:B!OS"=K]'7F-;OQ\$[1E)GR(C7#B&E'58&HH +MWR2LHQ]I\A5S)_-6?@T$,@JO.+:N&&!<`G^>WJ/E=HQ%)^:@((YO2[Y-M=]X +M*"4C5Q?CEDP[Y@U(;UMU4&]>5&J\1A!(@*2P-4%SCOR+?UI-VXV/)P2D7!=<. +M?:XX2[I^^A']%:"69CFNH7V'#.:ZG42I#S@5XJBC(L:9M +ME15&*?-ERF%9-(:+9RU55^4^8=2)BP]*?;/VUTR9I$C0A(&]#XB`U=<-5:6[ +M)4><;2D1=Q#`BE$F)Q.@AM)D<_T8Y=@1BAP4+>$``H$X3&>@^I^=[W]_='QT +M_O[B=/_YT;NSR!%RE)DH3ZZML\964CI`7"R(`K@P4WI\S0;%F`%D"N]RI2@9 +M+E)&HSGMVM1[GHLPT5%,;[4!BRO+CUE4YFJ?R1CK81E]VQ69]5Y:V?FJ'H"V +MO:EZ+I2?2[5+A]*:77>:5I6U1']1A8)5*PKC;CD]ZU#12(H+5`N'P4:IJICG +MUH^!A0@_B<=S*AB#JI`^Q8A%7#+I-BU&EIQF<4$]H"THVY4[N%H<,-$Q:T:X +MF=E5/8JS88U@`*J.,ITKSD83,PJ+%!P38YX/4Z%,3F<8@>VM+@ZJ]Z<*G)M" +MFEBZ<>U"9'=BJJ%*"N#!!Q7G:EV3(Z8WS9*#QUBLUHE%-6$,E?(G.'K!!V2= +MW]'T;5H@1-E1VWFQ&6&*OWSIU)256OR.IZ5IV=70E>5L,"*/P;<65/P6DUY5 +M;OGL"[^5(O%E6"D`U[HJDWK.S=Y.?KWVW24+7&^.FD"$+$Q8FPV?P*>>IXCV +M8%.>A/]2+7E4_R6-36^031HD:?2]ZWT>?-%06]XC6_`(UBNL>0J#WQIAK<*D +MG-DPAA>=]0\"%D5#.,_<04Y:H%6^&HT(M7A[69-4YZ?2K5`"\VOLU@-CM\H1 +M21+YA*`M_:JC>OPN@A2*$GX-XEDPU)(@'BO.!F2$2P%OA,)4@5:^JZK^I[J1 +M)+`G^K?+'24[_$^W%EC5F7I8126"PW+7AO]VY;\PUEU/_ELQ8,U06#Z?O%#= +M2!7EN6N35>*NQ\8)^F]^D^$/]*K.G6*R\-8NO:\']X%L"3C>H?\Z68%C]+*S +M>^-CY09U95'9]`*M\L#E\KL+_;4FC?`RO<[WX&W%[2C?ZZX<)L0K0(#AQ",* +MR*.R(#4P^OQ@J+H\2+\'YP/Z:+;;F!H)_RWUTJ1MN4JOIC=PJ;LH]"ARVFQ> +MI7?)7M]NPDF")=Z;/.E(J-)=6PL3=^W@KF.^=0)`.?VM&]SUS+?>`Z.4[%Q` +MJ?"BOE.JWS>!H6J68.J11RK*'WZW +M%W:H4G7]+9A]YP766SE+I@RUJ52,B@AK3CF'/.!\*!+$5"8I2$VD"'BW% +M9FF"A.8$+LU.S1==ZL0RH+[73C$Y!4P=)Y;J(<;N*CM;A40%&V29H,,P=*=$ +MF!G^-K1$#K_N='4;!>=OP<._)4P.C:!;N4A4EE1E*R?W2R5$2J5#L0859!^H +MB\;![0&!I+A1G@TGY2K3'6V.KE0(7R%96)8R1O$%^[]7Q=8CL49P<5+R+PQ& +ME/_%#7.HB+4=PZ46@.-P90Y3/PVCA*Y)19.:9-H6H%S8<,EJY:!+D=F5CG7A +MQY2+05)IR>LL&QJ3@5H8J:48]I#I?$&35,8K\LIPEPK7EN<2*<.T!10+%N$A +MGRPQO.4RDJ1(HCLXH38Q7"=16Q+HG0I2N#Q1VC6,3.2%CBICT>#V4BU5L6VGE@_!O8(*$LR +M=BRXE&Q#,8X_Q(/L,HW'RMTXUMNIHM\TGEC&6S'5252`E"HE&R7%R%4;VC3. +M*UO/>Y6E5(2J;9ZQXYH2_):!3R&[GO7EW#)"NBT#4*0";+J?7J1C(+L7Z,5N +M@(QRU[:;VY[<#

U(,"[]O:L +MIE.$7,\-*\"BG+"9[W$G&_'H%O">[F3CM[A#I3:G0(F/)X':?GA7&IW4$D +MJ-Z=$@/E1[ZSNY2%M364_*([.FXH=,B)!,WR[SB755"!@;4(%YQN78JQ,BZ0 +MRR^7($VI7)N:H-@L?(_(@H73\?$UV#$@$VOF&0$D'9T,6\`O/D@:`*39J(." +M3S1)IH6'G])/WZIAR&5%[EA*I]8V7-A*Q$.VPE/^J[)X3R6)O8J>$4UA@&57 +MZ,0`E@#T)L7RO6/]9%P4V2"E;$1^EB")]2"YM*AP=PQMR%2;5A,EAF/GUX#+ +M?U2-KPGS/TY@%"O[.^8H1*"IY"30H<:@[ZM&O2P14),GH0NV5^WYR>NC-_MO0'(Z>GGXYL?] +MXW>''&B)4.#&P2;DCEH)O$&C.-6AB,/3>#Y".95F]9^S;$K]H4A8EB;%YN5T +MXG4C:`K5.CTY?JZ+;%.C#@XJ$P!%E;.3X/="6CGJ*>C7B]L1^5;AQ&R[E0^X +MY,$U]EF6IEIH`KFA3FC85`T>&DB78Q5Z8Q83V8A#`6ZZ45QL^XA0=Q`48HP" +M&6T6C_!4C=G4W0E4I@9J>3*_BS\(0VM<172RA$FA0:!\]#K17S9?S\];_S8^;'S],?VCZ!Z5?D/E:R([@PNR"'<7:V[RH6H'76ZYD-XO'^* +MDJ/3(4AHDA;Z5/T.+8*6Q!P1#'0=D?$@G1"'X[H42!;8'69$813IU$F]4J=7 +M92T[)X<++F!/F82*:%BN'R\(%&&FY#"*>K+HN5Z6*C29A- +M9=[.B,+1EG'A]BL%D>4*U2&.[!;*B$W"32Y!D?SGC,)Y%)%QH^I1PT`0HGK+ +M>L?L$L0$.]U%:C.89Q0@+@P@:(\CLAK*UF(PE^\20$-.U8&G)[DZ-IK]REC0 +MC>ZZZN<*).DJ)$%39>7/'8U#E9/OTAO4/&3RTE(%&1M0F"%";Z``:U%YU>.% +M&MA+466T$S#`DX(9=/1C)_JQJP.$/5;/[=4947T1E/D?4=SLRF']6!R>,(9J +M%6#+4LRZAQE68=+]-L=DG3!&U64*:$R4B12$F'>H&.W +M#NAXX1];V1`V3,-#C0U^##?H25CS!/[<;C[%]^##9,7&9^DM]"B]L6/?Q^8O +MAC4WPU$`_;$7,7CX*AXK(SU$1M^[PBUF?JYV&4:@_8I^[)GMD>2@DHK`FR/F +M&E- +M[C)-)5!W$>P`_:J-[LHDV//`&TV/X:0J-QJ?P)\[M(%=M='T++V%'J4W=NW[ +MK`Y'M*O,"UF\4.?*[.`51^JCRPP`@/8'%6#+Q424(6)8<[:4O[SHBA.3-ZEJ +M1;STIEIRR1)3?H+6RT"H>H`'K((VO*'24UO[A)Y;MWINM0^J*7:KIT@_5\^P +M4SG#N@?4!&L0Y2%#J2DC9=*83SOX6]Y"W,'F.KDXUM>[M@YZ():CI$)LYG2. +MHAI!PM!U*#4ZS[J8F:D1D7XJ&N*@(XK6U)++*@]U(UZ7%2FIA`0@1U02AV); +MQ0PFLK=$U.,X;OVO4@"O%D3(BT8-K72H.19<"Z5V3:*/"4TNY*PSW70O'FFE +M@?/WQ"FGH^<&#H@Q>F&:BZK(\3+AZ:L3DKSV?WRY_H.*RW)"^4]/3LX[+"R/ +MU=&F15^%.O^*)G?:B4Z[EJ7&UF_L@?910M)R'4&+UL4!6B3*3;(,6X%;^(#R +M#!5],G-+)9A,E;_3=G=\6H]F)46-321/:6235&);?9$*$7%Q# +M-Z6.)4)G:\@=24(6ZIS;@*!6/5P=T;3*\^@;;4I82ZAJ1,$4?KO'3L1UF'6% +M%(@:>$90(#ILH_`\03WK>XF3(V^'L1Q00MY-$D\BI>Y>6C?:PPRPCGFNTBQ, +M]*%D^J*`(XV8I]Q?``0O4*O-NP3PHJ[2/Y)1K'00%9N&AG5VS^'3A2TTDX=; +MFX-ZBI.31:CWE'[E"Y9-R$Y'_`EK#MY+!E^-+;N%QK,!%KF2<%3;[Z1=$+J> +M^G*O34NUPE5Z)FDO<6[RF-VW2[_!1$^@8I:BRZH"Q/FS#TRLNJC2MX(-&'%J%ZE +ME)E$U`N767*-E3UB:H6D63NF'I26M6^)L!=>"O>BJ?%C2H5TQ6ZIJREROIGE +M9$4$8Y^-?U!!/;,,IX*+TI?)/_!R-+_C;CM(/>K\GMZKU(-L;L4`+R_"DEX4 +MX\)*$VSBR7?>0).J6DN3#=*@]%[$X^M18G/BHS(F2Q.G"M\+MX\SUGB&IVM; +ML5IYV5[`TI$0U$%.`S +M\MW\J//4TZEJT3B3[M0E-XCX4L4;Q69!RU-6Z0E3;D<\%?1VY39ZRGR.495C +M<_!WR[YHNR]]2+"V,87A`\_+=-XH +MS%R:Z/S(*908K*XS?76Y82=JH6()3/4:KE/^*2VZN=[P[FER#$3G*4N!+%F(:-3+@]Y'4IY.[0MCUFR2 +MT4=E[DJ30M`WE&9[3T'C^U8]+C(;_H[U+#="!>=O4'*]EY"(83:C$IT`A/\F +MC)N?=QR<8>@##*T<3\,-!A#]$SZ5P3'2`38\5(!5P>(YGC*^]8E,\EN`9^FB +MSI]`ODL&=_K4=;,<*N?#.X0S"9T@]>J;N[BEZF:/J3DH[2.+P>@53,A+.9Z. +M&%UR'_H55OC[QJ[.2.&KY3E646'.6WO87UWL+88*#).I/0L0F?"M]!++S?&M +MI172C\T`'GR`=?9;?)L,`$\^53#'3J1[(8VUQW(@!?E5J8EH7/GM'EE6T&RN +M+2M6O1V:V@8Y&'Z[9_1".3'P+H.;OL()9!\(PD>U.N<.$E3U'73@#`J*1XB> +M"RHV$:N7$%`=7*W:;8.O'@"3P06@*ORW6X&F"Z4N>I+^Z:Z$$LZ+'X1=^'_N +MTT#99K<@Q//\3:;N.E_IFBM.]JZ=K.N`S!G=`E8%QB$XEY]HVIW/.#W>:Q\" +MJO`:-,&Q5;Z'AM$>084X=YT6NAB9*4DM.U:6@>MC_;HT@1/8NF,1!<4K4BY- +MT>^IRB56WDD43>16X8`4^241CG^875-<4%!>W-[*\/)V$L--2GM9&C\HI^-P +MYHV7CH-!`!BAIW-RIMDT'F&\83P:%9'$+!?3Z#Z&S]%X=GN!3C)I.+(@%/?F +M`DL<1?,+SI$JOB;VK-PPRSMEJK)P*86'05R'+-75D6L'H_U=3`MKG]6;K/!4 +M)3CH](;:1PV"A1YNA0XFHJ2J8DH;HV2\M^X75>5F;WMK9^?[YT=GYT<'9VN! +M6PN7&I*08DHMZ&K3+\;`IP`0P_G>!A![_L8M[O8V>A$W\]O;[:A4EP%\!]$V +MF]PDQY;1^`G_J70OAGZNK?G]38,5?%X"RQZ +MJIW*/I56E\I]Z[%T(.&9U#5^1#LBX?;!S36?)_-6*=04R1W?BQ-:S,+Y&%,@6,QW)X/51@V'KQP+5*C<:=#N\"5 +MRAE`,0[?)49(;SO92[X,#`MV>\WM@;FV=-_U*5D*1%7.4]=TG17P2FSJ[B=P +M+T8.#6FU?@#3Z?Z;EX=FVA1V.S=00K.4`9(!CU.2].%O=6&UZDM+'4RK\505 +M2C:LLV3(C.#]I0]EL-+)JX=K&,R5TE-ME>P.YWY_X)7;K<4ZS8YBH_FSGM/@/N$P; +MGG(OA*7VT_X`)'>4,=Q[ZK=[I292]&"X9\>[>\=:;C#ME]PL/)U,$SZMTH_K +M'GOB3Q8:PKY;<%7(G2D\J?IA?[\5>#_X@*_ANW*3UC[44+P.A5A1:%? +M;[\,9F4UKRBIOSP^^7[_&+O" +M6='25!\\U#FQN#R6)$LP/HZ:%-!AYF*=MUQ"-#P[/'_WUIJ`J2VN1<_%B-6K +M.:#.$7V35;R\,(7VPB*E"#/8M&'*B>Y8Q8^D!)HF_)*O13*:.MCV/O`Z!!YX +M-RX=P'L+=^<)BMSSA0<3HJ:GN]? +M25T35,SL>#.#X\1#:%\'TQGLWUS:&YO.TV&E7N"4Z/AT'G&^VF0P@YXS1`!C +MN.2&3?)=#'1(OV[29"5:K8B.]91'U>R%K57G!P5Z.->`]91*K;>KC*1&3F\: +MN3*L[%I:TF@O[(=M$;.FK>FB`V+$2!-_1AY\-1&F"5;3\PK52Y6T_I+:D*?S +M./H0M>;@5B#&<4+?="N??U;%9W&4EX)1N/A/:28/TJ)6UCM.#X$=7%#QE;6J +MD`!J@2*E=U?]J^B]9_X^T?.@U)6NHZZ4-!4Z-7\%G\-"5<:"\7]S_1/AEY5Q +M_V[4FP5B-;<^+\/"DYHK@/%TKT)1"C]?5U)BN]E%$5E1!M/-#\B]@9(5BYCX +MVSU`0_/!ZTQ"]=$B[BVFI9-\G5JT#Q(LPD_5=I;AP:?9_"UH/4#?+0GSGR3. +M1&DGR%X5J$SHK#:,W77O4^VF@`A*LDR"R3G$70 +MT9']-!(6^??DNF&:?\D!B +M0M7=5>%OE6=@:HR0O*@:+="J-*A4B8+*$O,I>OIH9N<`;136Y@K14&K38`GW +M]'AKD;X:K6'NE+Y'!58ZW=?/:_8"")4#YM]6@?F[OR:8Q\EU_+<,9E.S?0&, +MY3IUDK8*41?_"5+CG*]!] +MOZWJ\U:U?YNA^;V*ELCV/;4^.9MJ:4W.]BSIK^#L"^VNAK^!-S&8V82;,"'1 +MVO_^K*%_WCC'N$'8+>PS@(.\$$3@)JEZ/)7,:*KVZP8.I#/EDD&"X?5>NZJ! +MCEDVHZFJ\VL1=N*#]SY,_0U#JQ\HNN?43GZ[H*U@^(7U&5=G<=092E.89".1 +M.U1MYHO[>(P17/S/,,G3._K\5<%9H.`@@,*E?P]1<$H%GU?M!.\VI9^[4WM8 +M4WEO*(,+9JBO:4)?)$VHI,-6JK`HUYV^/3E&K:#D-_N#IV["E\D`<-<*2T=G +MVN1"E;>BSH9_797TRX2W66!9[C_[JFK^+:F:UM9]5367JIH6M%96-[CWUFU_ +M1:`]/SP]^G%ER!F@43+JE_-UL4I"Y3<_<.LF+673+#SC!TB!7%%L;Z^W]'CV +M:]VJ3VO(K/0P1BKI'5R"B$QV+WS\ZK&:[#4E%3N^5=612OQ>-#)UYRU3<2YY +M:!8MFK_M)S,.7ETTC^?14D6[D=:9J;U^'-&=]\`Q;_0HI5?H82,L<>U9YG!Q +MMU24U^/^,AJ5&D@^@@@VFBLO,I4*+Z0C,[$>E'S9R;:<'+T$T;W`]N188[N8 +M8)>5#=$Y*#S@+LEY+\_.]U\>GB'1DR4_/GXLKF^8Q?QQGD@[>6R)IJMARE`: +M"F.I`E8D(Q`=J"BOAV!-#G@JL&&1=8ZY&H6I-#D\@?=;$%W$L+"1S(` +M29C(-Y8..*<<\46#]LP$]?A_H$/0]D?W!_](PY2(#2!GAJ61[)M8;N +M(9/<@_=XO2^_H8>_*1WX1=-0:UPT"[IGU4E\TBR6S]2O?__"&:C-[ULS +MP@U["CNV"MWOA,NDI#>`]])84#==U\0#I7^2+JP3IOL&TKD8QXY'?1D=YZ-C +MT_(AS-<*7K`.6UEFUZ6RAIJL<643ZGT8 +M#WR8C[/;E"N./:40GH)K9W)%>)`@V!"L:J)A+WQ3!#1,[(83$I'C<_;5ZO*7ZCX +MBK\)3NNFBCAI_3)NGKCZ6,S3%DQ\U7Y2V(IJ(NVH\*-N2_7PH9CY+00G8#=/ +MW.7-0:XOY&XK)L/%YY/*QDPR8W,7796IJ*O\%=^^0')18@N1'2,9'C]N<45^ +MLO'/+M-!^(KT_,2AU:H#!$58$5'6]@6IF2AM1BB0:I1AH1.)Z,2JDHE47%,E +MJ80036#GJ0+D/-S@/5)7.TV=WH&7L3ODAMSN/"CW;H#&19H=9(SI'QX +MHL;Z)E#2D@>7UX]7)>Y89SR^$"E,R#N)*)$M6'FE>P99@LT`4FK,O8S<`QU' +M4E_J:3M"&>L/#56K9F0D7D-L'1'+7OV#N`:-)\224NN]I +MRT>C#2R?F>*(NM\(UI#E2ICHF<"*>A/LI)5)G6YJAT!EWU6C$+U&=XHM%8ZG +M@8'WG1V]?+V_OKZE-JZ/&Y?.1B-O=-IX.P/_2=[8P6_S2;/^ +MF;RQ[;Q@JPF/;3F7^LU%_4+QK9O._3T<8M>YM-U<.(6>,.W?P4M+$6^S#+[- +M!X!OLQ)\V(M/[VG]X[O.XXB@!,--%X8+<*[CW*M@N+D2#'L.-<>U]/Q#CL#H +M.ZF<0P-9S*$>/-Q`7U:M'(EGL$\:#GH\'G84/>]#;=I[? +M:BX$8==A<`C"K@]"G-.6<[E?!P)<<-3=E4!.\.XJ>)N3 +MWUWEY!-8NR7DVW:N:?!QK<"8>^VY'%AD&%TMLZ5@^LR30_B:BA%0VJX7,&#T +M&K>'LZ=R56M;GYI5^'`O=?U055[J)<*[J[S4:&9:3*;B0"CGI]>WL>.&12D6 +M+R)%Y9@`O_D?]RM=Z(\06+"X1X^Q\#9,L`O01@>P@UX,MX(FFZHMMF\"D;(; +M8>^C#97AI0>5]SW!P=.F-9;4,:ZZUT(A$>3E.95C/G=;BBWV']@;5#'W]<]: +M-JRY:R_;>9<]H2(.]PN6(X2^!&^%XU7H/P +MGZL4EA6^DF7A:]?O14-],=/"ES,'U-H"0I+&N<@'?NI_`E);V.%SLXE[+RT,2SNHS`M;V07.V1$V\X>06@BF +MFJ%81JJP\0>KL:I8J+YE^HNQNXT47B8"*$QF0+W&R'5*;[^-I[>S$?=OXBYQ +M\50U"2NXZG-,V(!1D-Q$<;)Q%^?>*[O/MIO?JG?.I;0LOOL/EA3YAXV./]4= +M:ZK>8_.)=^]N_;V6D.S#HEW_E-C\^&Y+&`T=#JR>I>/U)!2[&%[U'9VI>KE, +MUTS%FA_ZGQIT.I\,X(EUICOLLPOX^PYW_I7[RPC[*Y9'UG7:,;5-R9=S(2GO%L"RT.B/2I.,91_AX11RR#\XD +M*V=BEN`%9#;=+B!X1/?VNOP0?>Y9GS>;WM14>CFW36,10W=[QPB4/!T.$[)D +M9V/ECIYFP++&%X0A*B]`U7X63VL.*[RXQ;Z_UPG-#U[_G15EJ*;TG1\\:[O[ +M`8\'-]%:@P.7T-^_5G<+W:%B!!J=9WCJ=)ANU7OJQGD:1S'EM9@@`QT"=%`. +MS-5QN$`?UB+9I2A<:ZF'5&P!P88<+08U"3#96,%'!Q*;_;).WJ)Z*];L[2`O +M/?'#C\E@IESO3ED!W45((0"&OWI3)TZ532QF+!$1F#QF+2_[L.(<$<)1VHWT +M=/5\55C'3W$^QEG1R5=@#C\?] +M2><9"&:8!1:NB454==G"`)F9=M*IS;"ZI]-6G)V^V7]]J((^BMK`&]PG1?*^ +MH6[GU%XOE&[I->'[3M@^/NF]Q:&F^`[L0F2?_XK,+1'+W-+=M?/FG`\S\Z_2 +MFBM<406&!\E6*\IKCC'"O5(G=+G1#DHX,/&/:Y3SL`8*%%Y7A;KXIY*$H&_J +M6L^;:MCF]Y[YW:G!9^[8M$=PQ!1S3]_N&5-U9+'S`#;Z@;8M*MX +M-IKJ7]JN8\(/@6L0D.`^WDO]LSI=KCI`%L%5/DG6.RAOQ]9S]I814@K'LH5=Y2(@@U;8PJ,*CJG)?4G'_> +MD[V,.1K.:-D%&&W:\SG/2 +MMU6XJPUKM&FK7ZMXJK7^6ZYBW+FGST\.SI[^YLO^M=OM[7X_A'^[[78'_VUW^ORO +M^@O;_:WN]F:[M[G9"=N=7F^[_9NP_X7G4?DW`QZ3PU3R%$6=8>U]XU'];W_' +M?Y7[;RZVX`Q\]CL6[G]GJ[>YW>/][VWU^EW`APVR8D<[X^N,QCW!EC. +M2PPC)XXBP_^4CF"T`HCLJVRF38X_`*N)X5**M1*S>"B7F0>%)[_OACO/3^7B +MN];OU&`)<)+1LU"PZU_'\75KD+5F']REC./6)2\"[M@8)]-6EH]'K>OL3NX[ +MXJ0X<4M-;K)Q\BQ\$FYNACM;_;#?Z70W^Y6W8J'JC]:M/3A9O5T""$`$6")L +M]*UXZ)%+)A@A/U#-M,^`2]S`:.%KRN9(BVGX;IQBZ[UTJC+Q-"M-/L9%N-WO +M;OC0*FYGK60XSV0RWMW8VNOW-KGV#0,CWV`H7VP@:=>4I"N(P+*G(>GL[& +MU\G&[V;3:4RAI+-1S&$L(+F-[KB78E`IMY&4!,<@'<<`'E67B^ZS\L^/IB9) +MO?#.\OPQ.]JC.8A1=*&!\@T@)Z7I\,=6$+RBA&[=RS$;L:6[4:X"P+1@JFZU +M*IP%ZI:64T8:QY$J=X7DL%#E+WHU)9:K0F`P#WSP%COMH*1&]>(S[.F=(Q*0 +MXI[J['.:QQ5EK'!OR@3;7`,\]J`^V%8(%22 +M3;5L`%J,Z:()0-%$E><6A2[&24WN$<$-T2-/L)"]RA9ZD>68I1-N;P>3>/`! +M8S?D>>S16Z376*:$3]"0T[^.6R]:X=E-?#LAKX%4D%,'-KNR,+[EH+]*"Z4< +M,3B]LX+25WU$P';8`"#/G!3@B_R"+W@MQE9*EPEU,+=<&/'L8SI*\6"80:D8 +M0S!,KCB^@X^4SG=B^&/BMQAI5'(T$NHB,D7#D38''*Q`L>2F1X9IYRV%]$LN +M>NM,5^"P.MC9E>?82FJ.=Q`/\JQ`LD)NU#"[1`CC,_&XN$]R2LN3L@RF3M"\ +M%7J@#"@I3'8;4?`6,Z$)Q\B9`WL<%Q\80D3%*'8>T`XFE`P#N[4'$9PB!!9# +M=2&``>/$+I/I/7I\?'C`@($[E6U"CL9B\*F&EJU3JQK*W28R+ +M)D7V$O;'WG.F&LA$\_22Z5;UT86]9:*%V?&\&U(4,0I_>AL%%&I8)37]]!9( +MU-GA\>'!^>'SB]/#_>.+WQV]>1Y2FE6["3/XZ0:6CEN/PRZAV)$*^QC>I87* +MV\?8P'@:<'7%3AOV:I#>PE/#]#KEE$(UZ1B1*1[,0VI=,=+>>"%T4T2HH,%Q +MB?&HR,+K60RX,TV0_NAQDX\3X-]`UP6MKL)^&R>>\`F_C:_A],R&2;,5'L+I +MX9U(\"B%V'=7N1:%UQD@7[P]/3Q@OD6G:'"3$>7+K@RT6Y(F+^O0!2G'6-=H +MBGAZQ2B.AZB2>Z:(MDEA2F`5-R1&J*H@"0"1$)R*+/7:P7)P`A^]XI(F:7&# +M.X(W(%QQ4D.0,8/G)^^^/SX,<8%'9T_#5ZX\_B&._R93OMK2"K(Q%V2YC0O_@U>';LXB8=W&+971@%X7T%S/*=(4UH([S1-TAN`0*+25%X?-WKU^_ +M#XH8V#4`"\.\<6N$F8ZQ\HXB_-S6MWY'U5KW0OCOT3%L6X,&;]8_0DN&!\Z/ +MWKS7=P=4'T-$9H(EQHO`A`N]?*1"+LU$B<1V\+>"PX\Q"B84D#L""@'_8HL- +ML]D<%@#/"=&F@L$I1Z9@GS]TEN0H\9IB5+Q1W*31YK(RF"X+1S$%NL('BM=` +M83A@Y%*"B&4EZF48/@Q[#-,`QE59:O`>-,_`$?ZPQBWA)8`'Z.0H'B/C`_V$ +MP[OPU$B0!9]7KG^$+KWQ.!F%)^_.W[X[OSAXM?_FS>$Q;[F43Y*`$8K;HRDU +MF)>J`B1XM"4(+6&"CK=` +M>@NTZ"'#X2].WER\V#_?IZD&+_'J_H_`YZ@8>@O4>V]!S&;"!O9OPHZ;X99= +M6R8\SP(1"6@!K-#0B<=2+)IFEC@'T(_7_C6B$(P2(/E))Q)XFTF*5V('$B6A +M.X$M#]:`P9Q4DBH133!4!<-WX![)GB=S=`2O&`%YDKI>!R>O7Y,K,!FCR2/$ +M6\*UT]]=X`]@Y/+*K4!6%L0`KKA4VAJ_A*E+:.M!M@-/% +M5\E:21@Q5>CBP&A#U?(E"2WS +M'`A?TM*(YQX<.G>1H_[I4T<%*Q!_<0)PJCHM0J6&1B5@=UVY5E6$'7[NR<^5 +M/VZVI!/9>R2#I^?-ZL/!P@#.`_;H4J44Y`GIIX4U+^^(\.Q(SH-5D2ZQ!^(! +M3:KB*LSF9)QLZ/`2+!E%%1[AME$RO@9]2(1H-CJP>NEKOQ'*"[(>8_P!W05C +M`2V,O$_47@'LW[TY^GU8#/)T,I5<)^27INZ']6!@65/P@"*?AUM-O?E+";A& +MP.PS8"K*3,+4&`0Y8M7;X\/?>]#XWM\;5>6$6CDTV`"#V08PAP8#I(FCH5&B +M0::8CR0Z6>!4NTN2$%=7+1Q2M]B63O/U_F3N_-S_"6>FWX>9CPY"M)_+.')1 +MGH7K_#ALOGG:N5/PJ?KQCCQ^?N^]W'V\6_-X]SEKUBQ5V`Q/CMZ8^;S5`=0^ +M'*R7DUL:*,H]*I^8W4-5/U&](F2R*$^>`"U#>]@836!#I?]5T(16:%0:5J65 +M3:V><\%L1.)@Z]#%5;`HH]?9RF_0*^QV4+#7U/RZ40]H@YJ] +M1&$?^(J9PI7;S-N*A3!D2Y&]`;/"C+MD`^3AJ^I``Q5P_S*MFHS1^%V&*^97.O\13^>8H&^8HJ&--LE.1(@&2,&Q#G;K+1 +ML)#-$>N]-4K5(%R(`OX%+4O-0#JG>^/4/'^=3?$9^*=TOR3^EW^RHQ$IO2M< +M\60`E*_0/H=1::1#ZHCTV43U%*1W1/(N[C$8:5A%!DS-SW@K9UE.58D#^?"$ +MP:B2:^3J=[R]3:JER'&%6#F1]YXEKG-G3GYK?F"P^910WCP5ZJOH! +MF:1\^XP9XA(=HK'(D?<)?T&P4?7W/&'I1PC_F0GQ(0]`Y3/P%P3!V;OO3T&; +M.WISR+'9JY/CYV>1?2ZYDEUT +MOG_VN\CN8!R]DG%>PQ>0N-',0]T!C)6DL/K]Q.P&*S)AG&/43M#DH7LRH[L" +MB\L'^WI_>4!2WY$))D/6#2C`5=_DZU)9[IG]T?Y"?6,O"[30CJ?>^'GB33FP +MIHQ>L-.7[UZ#CGSFZ-"6Q*^5:%2AOX`&_4`%FC1HV5TUN4K5PU+VFP%[2FW? +M[X+64:RE*Q%^HTY]6?P"4[A1>7G?MV3N6!5\I9D3A!<[>14DQ!ZGFYGIMG?L +MJP/1G8U_V14&HZ!R$9D\*D=CYUVC"K[`=]%@?)L]@E/K/3M&J+?#Z'`]3?9),$&S13OO(W) +M,ANH,EA2P`*_6@[0B!QY8MI6U2!UU2QZW0UHZ&///FK;(^UEDFHH:PUUD0IX +M`(3]41(HVP@I_[8;5AO7V3XOO3%B(PMI1T^@+$J7(5%M +M.;%:H*((%&?H_\^3$1=YMD>09Z.`TO3,4B3+D+HS%%346S]NW%C4"0ZNTY$- +M'+)OV[X(]\G'Q2U**A#.LKX'Y"8:9#DEJ;,32+=CB:4>/UJ.[IGJJFTRV +M)P%M;;O5[K3$CYS>6M9OA=YL]9&@,GT`T``8\$JG8@EDUD;3`I`":QZCB0@E=M_"'>_#3%JRX\$E=X8X1-R.F'H>Z]20<4V_ +MYF*^9HD=38Y)"9S?.28`$($JSI3ARZ].B)0,G8XM+&)R'W!ZE5;E(L7216YSJ.AQ9>D9^`[>P&1BLF`W-C#5OD[VJ<46N@B48'DV8>`,QU#S7ALI0@Z2 +M2*]OIMR5*.$(@8@B$^U1]D*;VP$?,I/G3G<<\ZA#XJ8PI5'@(*`AGJ"IH/FZ +M@9Z!O9_>EK4>GTDH^NMJ`BB*8&ZT&?<[?YHHT)M%E%[K.B.<:1SH@$AMG]*V +M:EO].KC),O0]3+5H[1**X+TBZQX]82V^GJBR&EW+G*V#X*I'9KD`#8L#$#". +MTP^H]V+J&TNRU*WNQ[>V?%D*[ZQPKBH9N23CY#$',BAY@"2X!KM4FTISP:59 +MK8J5/H_W&]&1@B]L^:^%-0CYK4S?@@K!NS!O54(7ZZ\8WQ">8O>=$3FW*8@G +MLD-@Q0%&$91J@SG6&VUD5ZE88RH]MX$T"\0(Y3R9`*Z"GB,2K;.U4M[8Q^OP +M578?#$:9='^H$*!3;>EP@")>N$(X`Q:+O$Q'Z53'YJF:*V'X.B,KD.R]23!$ +MWJZZ0Z.G)4$R,:)BAQ0.I:*(;:`6'`J%&!GG*A!2+RRP%G:>A7^8#:]Y77[@ +M8'F=0NA0>P,IB1R2YGBC`0H/4,K2$`6\$6O!^I+L.YTF8I2@8%Z1]CEP-[Z& +M$Z+X.^F[$MN!;:5GHRF+`TQ5%;'4TPHJH""+8&.:3>]%%M/:.2;J,*C2@O!X +M?R0)*7<)+B16,0<\;ER`>EG+WPG!*]=6LT%9?"B5WC(#5T9D@L'.,P:6\AT)\J7`EQWQC +M*`,.IE]3L)PVO4]!@@LDG#FR!;@2_P19+1E=11Q*:*!3*#4?=':I0IFB$90B +M,B>9I/@7S-E8O*$`(HME:D1EMEFER>O(?XPGRW*.)[-T\\(-I,?XUD1%TV$9 +MYXHH6*I/6BCN"T(8*C)V])BN^D:I#)>J$REQ? +MJ7IIO4]UKM-AV_A+`IQ0`!%8L;35VFU$.@)F)<`RB]DUBMBEX`Q#Z^6/,V-T +MT5R>>%U$Q\:F^PL)B!L;&)3O_AEL](?:Z,F_6^XO-$3E4!I!2T/UZX;0\JD, +MH7%"HC:`$(QBK4F08Y*MI89:V42,)'RI<"(`RI,KI!LBL8@[8,"*C``3N?#8 +M%Q$XM%GO@D8N8I?:XT0XY!-I8IRXQ6.,W(/!0*1)[KAV5:#7L6`9&`>KG&4R +M.I4-3C@"&7EL0?)),6U1PT#@K@B7<:*?0BK-A@@XKA2X;67KB,T<*%N6J>P& +MH<%6#H*Q)%)B(R._;6=11R4*1R!,!Y:$'6F#B6=5T\*:D>!)YQ*]'\_A.+"M +M!UY>Q%`,(-;PMAZJO!Q%@&%4?*I93X^<79*(:Y3%A%R1QZ&A5!0:O5!5TO5TAN, +ML`;RU-75&B^0U2=R>MZFHR')J_"K4919`$S9A(>FYV3"A@WK`+AM@XE>4\-? +M-;PE#0/P$"$">0N9MC18=7I689GK6.Q`D46+V@1^D%8H798/C%JQ>'"$;$\U +M#])Y0I=SYW"00;VXS4#<&E.4?F'ZA?I>0J6WRDJ9HYLW2]`OFK@Q5P0D$)8& +M[(-3]A&7$OZF%`S4*MUJ,ESK]:?0S95#!.1TN0?FRMGIM#*D"7`7CY@8B21= +M3A=/QW/N9]8%E%F'IHO]L]_9DM4RP:I.4"+VBF/1@=`GJT4OT'+#*?.#'(65 +M$C1MB:Q2WH$!SGB``@?P`60_[UH.JJ>`_YCQ4&;9']LJBJU'N(J^$SIL=)7` +MT57VM*IBW*#6Z+A#DV%<]IH>@?#`1E31D1A?M#$N1.Y0EP%J5S+#%$"N?_K, +M-E/?9J"Q<[J-$X&AUFMK;($U842K/$%+3T'3&&:S2S0U2Y-=2LJ:LHDK=57U +M@-700BB!-68!BLRM[@=<<.*7=?;A>94HCGD@J=8;AY2&CS8(N(,\=N-B9CEW +M>0PDR%-F=X-\-DP"BT'76"-X_`'-`QT&MF=/(CL#WSLH56$MG="V"(C;-!G4[C2^F=&N0#08T2115$"#N9'@.M1,X&H<)]VZG +MQ/7I36)ET<*-TUD^+H1IZM0BSG>F&+#&B^/]EX#96TU!!5YM/`WJ]'RJNIIG +MF`T^S.[16.H^]6+_^.RP!7>+A3Z>8MCNU%NQI?&[ +MY$,=19!2J^^/'`+N6NZ""BQQ;":6&:]Q[BC[[(#+V387D&%@!7.`S;P+$L/Q +M=2!+\R%@\8)%Q!*;;S6U\L4$FE.F*UY52$&*>*0M'&CJ5>G(U/DS\$UMYQ5" +M%_E"J&<*HX,.U?!L.NF5>&.83.C0^E?:G8%J30M+@?%3@3$1.`8I=D8@L3!Z +M6EC.NA61'JNZI"B$O$&9'4;!U#])]R11E>,E;$\[F?C%D:4D#*Z<2*]F+J,\ +MCJ6@$T[SR8`%JC`W@B7J)!SG,0$)$.C+..8<_'"HJN8[J743XH>Y_V5]A#$:BB36(H +M]U)0P^H45*8E>@R%'B2GKP'6FOR`ZQ30`CANCGL4S+2&!$`#CFUA69F9))HLAG?D\8;IRL$Q=WI=,Q-($(-,5QM%.J#C73:(00-9?35SJJ8JWG574 +M!=,G#]Z=GAW]>!A:*1/>DYP\\2(ZO_AI_PUF3;P\P1P*_._B,H?F[_WSP].C +M'^D1Y+K-AZ04`.N">?WZ206:'563KSA/-,9)4(#.NWMA9$37]ITA@>@FE="+UTPU`GP7!BW=O#I#EAR\:L#?- +MX`%I$._5K94W+HBP>?&`!X.7Y-U@KN[F0E3-,#S7#-;$ZD2!3G6LM4.:&!_* +M\9(`;3+IH-)OF6F03+RH$30-3[$T:#V1JDC`P&8+&)K(Y,N>A'6F0SY*RMIL +M:%9-1D\+\Y!E"9&CW^IN+U)UX&HV`E(8$!W!D#D\<30G.J_\29]%CAQ1EA^S +M:HX_SP('_(L61N]A43HF_T0!2A&0("R(&07T*^W0J%`KQ]'$R-+1;DS'(I^J +MDE(QZ)+R%,6L\'`2DT6C(L2L<:W2,6("4!')PT!.J@Y29QW@W%4_EN2,!$Y$ +M8MB@B`EG*XG3-"4?@$XYQVQ*)21UJUJ689=9D>2\&AQ9!V%I5J;GS4!HJ!F) +M(W!A6AC.1UZ(&@Y#3O)SU$P>E#LUQB(_2Q.GI,QB[$1"20Z%GQCTB=`(7&B$ +MJT+C2-M9"1B!>A7\]&XL%H&8DALL-%-!J)Z,$]0D,.',*0"%O])YK!=_5#88 +M+F?U;+!]`UM-#^S05JL8T*(,MT!.(FA0](UC2!]@VJ"?8HC;) +M&:/*T>G:`"BAG[ZU8*&IH*+06.!;`R:?$O./RERPM:PHD,82EL/,V1Y\X6*#6DU--YZ*#XI=M`&*T0&N%A,2C +M(<<(GIP]PL(H([\*8:`XSRDYF@14P(;TWFCN'H5ZA>6E/-"NI`&ZU+I$&[)! +MI_+EX6F%G8\.*FIE:V?O#@Y@_#4Y0WN*&@0!(`6ZE8W`2/U!,=!79P".76F0 +M#2KCY%[3;VRO&E2:,BA*UV`9/F1)+3*%D&9X\N(\?+%_=/P.J-\:SJM+AF42 +META:M\OS4:0($07C"'KU6.BEQ6_@('&NII0DM'-AE0>(T4TY`S0)XGCE83#, +MXT)9SF^5*YIT2BQ&8UEHZ$?1TBT62$F.6)]DI.ILWKBTD`N7F8>=@"%5P2\+ +MS$)?/[:]5_!P`R-0FEX(2F6HCJD)J*)/,#5,F1AL(F"+*,QQ;.][H,PG;W4= +M@M2SK;C>>K\.&5?:#:2LF;4MI8IKVM5,;$;)VB0<4BR0C0",BM56-1,PGBCK +ML7988G!90,%E3C@1A?<@A!+?A5*7>`T29"#Z`IVM'N#PODY<)E$POJ5NZ5*X +MU>`;^9N&IG!F8Y+#@HHWH(.,1-^1LQ-V6!-D3;;^&$Z'KW`PNR< +M'Q#VL3,-WT;N#9H(9:P7Z5C\MB.\D<(OR'HEC)3(%$$&$SG4BUY(D3NJ3XS6 +M7@>C`.#L,0]*'G-M4Z/131GE:3:-1V65#%Y.4,GSV62*N9A%ME`37(14@8M4 +M*Z`06XL8#+P-&`^RZ<7`FUY`X3'J[#J@#GP0$T]YM7_ZW.4I?8;[,$L83W@#0B>: +MA`N4NN$D1J$'>:BVI$&5\&.8G];P`E/M.!,\%UZ;TXCR!`9$JL!U'>)M.C,' +MRSLS`^EQ`L=-.'J$70G5JB.I%\$^1I6KKM=NIF,5#D;S$L"$Q0]&(%R.J*@C?./84[U5EO!"M=>I,+,> +MY$I11PX44TD`&(HA5@8J_BR9]=4U:CP12W@>KUACY%#E98GDIH\;.MZ--;RR +M2$P@&VM2#YV;AYD*`@YK`@]5H#K&B2$@R7FO;'YV\*X^EL1FW8@#L>.@D>\WQ+@H'!IV&@E'P-'-D(]=RW24Z.#LJ\T!6_V'RK"0O[&U&H +ME#T@==DGL,XT'!=):"QC0BUP[HX".\0-FY(5Y[O-X'/*. +M*A_>HV+U^HCW6TU1->/K<89`LCQ`5E(V8;T].*'-95(NQ16>$$Y:H_`:K#A3 +M<_SEZ9@JFT3**ZB]R!9QZ7!$+2$?62X.&.[W51X3G +ME92FDMNW%%J.Y^8'-TJIZB45V!<(_G`O4:MXM3:AF(.FZD55UJ<*M(&Y@LY1 +M[*90>F:E%3(EVK/>7[PY^8GL'>YJ6)I4E7JIC@(;TI`LZG*T\FX'T9O8!L#- +MSUW#O5NSUG%Q=GAP\N:Y4VX+-8R@4L-PBV]9*I)M;]4VF[H44=_:6P^^B$). +M2J5XW'H]7,_#S-^8<]0\W:RY^+)HH!-6K;WYM%PCR)*2L.<-EV_2%C4JX*$* +M>:DX:',TA$I/K6+D%'H9>.XI>@(.7]C(05K80-:]48!:E6/G,5FTG"N=&NU& +M1&L!@*&N#[*2#M0HNG46%2A"*:ZJ\,=-+BF+IBQ128IRO(Z!\3KR>9'72=ZR +MMG#:4]-:A0$E/1]TH\`$@M&LL`'B`@:".FH5`<,A5_3&]GMY)64'#/ +M#*8-.N6KML`((XI%Z3A!E*5%=J.5WB$&>&YS128(%6)`Q,@A,YJM*<[L&O$[EA]G=IT9!J(ZH9H!0.@$?$.P^EJ@(5X?0J+Z3N#%2Z +MFA]\!BS/NT'RH(SDH8OD"#.-=V685YTI]=7U@_(46&3\YA)B\N#O:/C\\BHIX')V?GT4_[ +M\+DR8.[-N]<7Z*VYP)NQJO";P]]C@)W49\*RPD9S<165N"1Z+JT%;&)-P[*/ +MKJ*VE'`2>PY+^<@*%8G_7OB(LYW+76_G:+VN,LB_J&?[6%,@5J*K8A\UN5,\ +M*8U5RR=T(./$"%UF1URJ4EGXQ'BG)>?4`J#$QQ'J/H0G6$U#.8,-0TB(J)-Q +M!Q&%M_(V24I%7`.K+`J(N'90"#L'K.$E$]B\A`$JT70N-N^':V2,7`/.$K-C +MQ%2JK$IO2LE%@H9^H'HSRR%LVUO/66?'R!N,\34I_F6S?L#\K +M8N,3BY>.^Y6 +M#\H8!%0H`Y@*WJ30,LX3YK@?5:ON$X4Y,T!J$H))ZKC'%GRJ8*!FV9C%]+[Y +MX/J`C9^$U:EUP0ZGVI6N*67;:+E)+>$3G)+ +MQ6+42/'P+E8^9/MX4,LX+D`LZ2M6.G:I-`7%1R[(7]$ABME58+=DKJRC79<* +M5+6,57HT$Y\0!L41JH&@/Q7V*AL=B>8/N0T8]>V8<-&`E`JRGFG;DV.5,'EZB+TF59AOO57V +M$_XJ1EMTYFQP5Q^[FG04]U&3C?+FY*?H/?^7@QOQHZ27U",IT?#5VB1@)'W9 +MBMCBIF#W\5QQK5()$\E.-FE?`;FLIZ9M`A+CV/)T6-M4V;`O4`W[PI#Z79?7 +MQQH!`FJJEUX]>29ETI,&*6%64^Q=CI7-H15/I`_+BHH*90B.X:O*HW3,4' +MLIV_5`'5!<,";UFPNC_XG.UG.=#2OTI448-(31%YZ67#OY,52&%2ZC&+*CX!7:45`'31D'+(`U;0M@+/10@>#L1(19`%4UUG3P*W8'57NG(`6#/Z-.K1R\ +MZ82Y(E!9+*79$"G2NU25;Q1(OI'VQ+&-P\(L6VS2<;XR:5Y4BYJUIJI;;JSS +M`)4YFKF<*B!!(XRXOK9:.X8%,S"D6I-H<63KH?`2EA>,`<::EH5C5%R)4B'% +MBCQV(N^H4@U#`;GRE+HUL7FBX*++D0*25;2PJLBAU=;`1*'I+5(1F[`=@5>A +MY]7C%C74Q,J2-8;J#A&[:Q'] +M/(P*&MQCB,2(/7ZV:3"(`TH5$(Q9Q,9R@U%JZ$@5,`-,:LG3`RFR+$,Z!%9X +M-586J2Y:V;(+;"HR4RVX"B$*6&NDM$C0;E).XL-'<6IUI1,9D4+J-,UEYNI) +MAF(J)-/KVI=R'L7\(I4@06Z0]!O*'XA+-2,IA\!D`MIQLFX2_Z44M0)]+7)Z +M-A.&Y$I\ND5K)*V8:M'@M['T3_@[L7C??,UY_\?/>3\92T<4"E6KTR;0::OH +MI`[M<<)%`U*6D8(UQ%8%Q^Q<%8!:T($0,]H973F;-^"9^!JF+L%?)ZIC.;H3 +M*^%7QI'P6<0K56C($5^HUC`:ILCP(RU9O/K\K28GICNEPU)N2':97IOR5E(5 +MWH22<^J\%KY5M&YU!9!X2/'PSO2D>\8\4#DL0*&PAU^!%SFQ<)J.B%_5=;T` +MDN74BE0Q5[3R5)6*+3@R$4W$H:K]B,Z(?$;I`)GV?=RE,:O##8VE*U7`PK#S +MFLQ!)U7^2,)DB+Q.38R:%4\45"K@W,E@'KH@9\W5*@YI?$J@2^KQ19]&GS^. +MM7K.]8%]"!8>:^4C%4W>:3?)S@WKS5\F*=?-NV6#@=8YI92(_<-&>XWPI",H9R15`>5@.<96(^?>70EPR +M=_U%,X@E?U\E$8\Y1PD/>5$:XB:6#!TV80T9I\BJRZ:WJ,KV!J($*:O#14G* +M05IIH6*C97VF\MQ+[@U6)WLB;56;.%RG&9HD'6>9<:&I\G9.^Q*&IJ6RAHN1M#9U&6#S\.QE/V?9)"W7)BF'^Z*TQ2IZ +MCG1`(7%6UIGG_Z^71.SL/S_2F7AO\%R*\8Z4X4JGC+E +M)0=^6G+XL+1D?0"5XBO6F-7RDDLV&FH`;)3`"GN);>F`]:E:JER0F=_-+_42 +MDK6/(Q0?Q](T,"0%PC;+NNS*Z13!PB2'`M6Q97=3_7>OFR5.)S=W<"G4D]KG3\TD#DS+J\_+)`XH +M;/IO,)/XS&0/JZ8'5FXQANR4D_TJ$GH#*\5XH1O;=18X&<97;HN,3\\P#KR< +MYP=,Z(LF&%O+"SX]P3CT$HR#3THP=C'RBR!3?8+QXL@ORT.T():LE!AAUR,V +M(TB.!7Z\>'/X$^B-$GLR]-[OQ4<1WE`H$3DOR.7NZTV!5GI6,-;S&;9CNM!= +MA"`-M+M-A9Q9GCPM4TG@`O6.X.Q+-N-+[X+`]JMI!4E/$(,1GP7!NA\W5I"@ +MI_QMK8H[*MQO;.83=#!5I@A':>J%&VP5>QE,<'#Y854O&-N7- +MHD!2::PKA%L]H +MSZMP9,_ZQ<$$'B585G??R,(FQ[VN!JVEFO@D9+5X_W'PL/8;=;;&X-/;;RRO +M?+&8-SVPXKYE%%N!R5D,SGK0*[;_7OYAFS=^_E261\(P68YM#;#468OZ!+ZF +M'ES,%[WXO<`Q[94R5J@^8%50E1?4'-@&/PQJ+L=6F7H,CIDR+>S`VB&'"\+K +MY^/L-J7@.`#,-88#]OQRD9*/4WU[L.7?_EI5ES2W:W`HKSPZ*>;$!35G1P67 +MFJH7!5&6N@+KRGM<'1H&96+R; +M4DRPHV)H7;06W:BG4!A?^)./N,:W+LM$WE0PEW=`;-X1V`Q"^YF9.6D^X>6M +MLEF-8WS0PS["G"PTR/OY(O@JTU#,.V>$6D<28\V#4:=")U-$)F!%V)"I$F0E +M9G42;R$Y=8'5-XTZ]$YO2&%WVSJSK&P(V(!'"B03LUHL*&2$DI9":D2 +MKB"+#C_3R3!NXEJ@`RU-LO`$N^$2FHXS!4(4Q,GA8,5(6D,&/KI+&I'7X)%I +M'<:W^Y)M%H)`ZJ\Z3!=$QA'X5A223_PJ*V;(>[G>U;X +MLTDXB(.J7@-D5)$!SR].CC'4;Y3=1VJ&`R\80J()JN(]=9G<]ZK-L^HJI',7 +M=:'@P/1E0]IJ=:B/U:VS::%">S3M^3>:(B<(_7NDJBJM$7:KK5FC5N*FZP]O +MM`(LX<9LS)$E\6"*IA2U\7:[62LHEF0E)_E*`%]OF`ATY*+J="XF!S?P8["<(7@-[35:<%7)?I8]:=1$U-]-14EM:+" +MR!_IGP1J0T]O5D>T^MVMKT&(GQ6$^"E=1SZOX8C6;6Q!0:>X6E*=[M&#!H2: +M[#GEAJC,YYIRTD#PWEGC2EM=G)7*JE+M0K'V")]>PWJ]EAG5*- +M[@"DJZ(^ZGK(37Y&;(4$U%`-8!M*$^$H'5.CCH$6>9S'RE(88BA+-I!CJ9QP +ME*H%.F:$FY>1QN;XWK':WGB9(Y/=V=UYNM-KHA"&!XL-E'_@7";0QS`&ZJ@5OAS%0TS+K@`^ +M:652-XCE#-H,<@K:,SIM_03;"^\$J?IQH;+Q;SEQ$(-ZIR`)P+ME(A+4_$:5 +MZPOV1]<9<(";VR)\"6=E$AY/@8><92Q'.G-ZS'%(<3ZX007Y,B[201";YPG] +M1A0@89"0/9T@J.I:E!,QS.,\]EF`#5ZC"UM"5!B\&&^M&(ELU0DJNC2MPW&2 +M7\_#4ST;3I!_USJ#,Y;@"Q2<^$Z,Z:V$'V4T898X/**!A$8VVN=KVLJ#TY?A +M;K?=[FVO4%+B]/#%X>GAFX/#912"J03!.4^(5>"*V<@I?A%]KKF2D@MG`^%6 +M0$Y5[V$N[Q&9(Z8KN@Y#ZP@,,DR*H.`E;*N'!M1TD$ZKZ8N6/5Q8&C-.8!?\ +M8!2>C.(Y2IADJ]C(\@T*[V8/3IAGICVN-6A@(3CP`K3#3&:79&HB+LI/PWY- +MDEQ51$'#O=E3U!5OX_P#O+FQOMY4H[@S0@#A(<9-)J34,R$OU.`F`W0K`A*O +MU%AHC#MH[8,H!8NF'H<_M5ZU`,URM(Q%0&OA.+Z,,1QK'I6.^-L6L.)7H'?C +M@VO[P7-E[#M'"ZXBI/IPPC$T33B/I#;.CZ01G$@]G."Y+6@<*D$#%/YP_^`U +MC`LO:^%IQ1.&Y_IJVHK"SG;8Z.SN=H"/=S8Z;5@3K,SF$R5ZA-,->XTNW`7T +MSN=`+P1#UB(4G3&,D%]WG$SQ=5U\V\YN,^QU.QN];K\5O,FFR3,XD\#.)32^ +MT8V`7")_L\/W*LBRHBN<&VN)#:LM8AP>:GN9O83&9M3GQ<$B3I,)6I)W=C>Z +M[4C6\ARO10#!&9XV`"@Q#N!X%@>*PN<@X,2@I1,?BH)W9_L`8EA[Y9+IE9^W +M9)O\1XZ0X6`?(J8KC_S4.@;`)!AJ2*AHP6+CS1Q5AMOP`(C#,DSJZ[WM;&PR +M)L$NV-.BUSES`512JX.S>O+\$!$=0`COFDQ:86^KM]';WD++&NS7..:"$W0J +M6OQV>&_8>,N>=#C\]/O9P3X,]'BWUUP#-05XV%O:^'S2C((?6@>M[^/1](]H +MH[I6#"9\BT2E0-J)F[2[:3:)"6D!'&9$%8O:+L^H6&7YL/NH)X\_`\IS-DNG +M9#FT,?"`2+$B`NYQ?VN5P@)XX?G&#>`4E&"WNW'6^1P\#9%S[D[P.4ZFH_2RJ>!V`"*[+N%:P/SN*:`*O1"V]*W7 +M6$;QSP/LO@'L814C(P@+DFUV-OH]W-4UG#7L]HQY"_`1(QP9L:00I#IM`5KM +M7\?Y?3P"ZOG3V=G1_G[8A4]9#H*U)1F^!5F)\:JG\2HM!K-")0,)FP'-?)05 +MH*"S".[R:R7Z&$@%&E)+SM@[,I6>H;V#YI+D5&;MF)+BCBS_6(#;\7:4<7"/ +M8CETIA27"6NYS-'K?:`Z"'$YG_MP7@']=A59Z/?[&_VMK99/JI9MZID*&-P? +MQKGS__`5O80!<_&2"J;(CG"(1#I@$UJ9KAV-WM8. +M>@X<,+GG[)2U1:T.O-E_&1ZGESG``-[AT,'`H8-$!K>1#.YL`1UL^^_Y`60& +MN'"0Q^EURF?B`(GU09[=XSF%F9R+5.;,*-`S`OGK^Q'P-6!O'PF+;8"'S+%Z +MFQX5P"-/N_,:]+(;C'K-\;#_#BDH3->?)4@GWR?Y'_$(XPQ?6_NU]CQ1L3EG +M%,E^I#U,A7)=N=`Z.WKYYMWK\$UR7XR2*;VYVU/;T=G:Z/9$[G"FX.'!,8KT +MW\>#F,N[.2BT]I8JFR(^[Z.W!%`YNS*H3>>'+.-5-`"FM_\:L0:.+)++*1:0 +M(`R*PIT`9[F-\DIWH[?9J3B_\XETUG3>AC$M`!7*IH1SG,U+[#PHL?/0EV#J +MP5$%@WT5VP_,?*2CH@*;A5`AH#-5YPFHB,-Q:TY.9R=D(`2=[?Y&9[>K@/"6 +M392%Z+26EJQC?"T/'P-D[@DXP4(!QS"#AX$"21O3,'2=(:&ZHXG^1`F$4F92 +MN*>]6"6FAII8=/J]C4Y_2TDSRN1`DLL!U5)'V=^2"6KP3%<1"(Y>GQU'=$!P +MXF=HW#R0LY(2/IYR4OIN9V.KAI,'JW-R.MZ[G?*6F:0KU`$)@[5VMU`J1 +MEDHH&Y@0(,R8/,XM.MGOTV$RF@>DO2H7*F(BJ:!*>*\WF@'PPU>@9#'%#P]O +M+Y,A6C0LH`>BAR2&'\RF'EZ3YK.#FL_6]L9.M2JR'>U\KESNLS-FNX>V4U8- +M:"MYR]4Z1@TA5%U:S38H3H`WNVB?*+TWO4WI3+S5@27PVLK1A22@$L<"I*;.YF;%>\Z`#Z!#X10]_5K(JR*\JS#1[F9_H]MO5[Y'I3HAT-]D +MXPWF1@M7%!X=/0-=&Y.+B3SH,4JGEH]8:9J.SA,0$]L&]K"Y"3)D%=!YL\G3 +MYMM\B3;H%_;0;VT4P6=3]AM@@V0F%S:&YU+`0PB4XJ@ +MQTH5="=$>OTVTLM.!WA$I]NMG-.D&-RDTS^&%/09J]87I]DE.KV0`CAR>7=[ +M8W-S%\_3#ZWS5G@R3("V@^@=R7F.)6+HM3'<`AJ,4DK->9V@XPK$]0@K'4QO +M-EYEHQ$1C_U;%'Z&Z&&!\U\%O$,NOJ)\X*J4_`D[Q-*Q,U4`A-@K@WT*@AK& +M8:)F.*`9*KM'#_G)]D9G:WT&EW-N$5W2I:_))S?)@N*&Q3+%,OJ+03 +M`>]$Z.]$=Y]>NM4,=W;Z&SN[E609[G,KD&$[/8!6)14N0^M' +M%8[`W+D2>(&+6J4%;8K$&79!9^QN5;WX7!5C08L("DQTTE*NP.N3DDYG9Z/3 +MVT)28DRJ%ME`A`%\09UG-,+$<$PT:B&QP>D><0.4RGZ5(%OBJR8PL;EVQW88`HHWN=EDP-^G` +M7%##TDSFVGE08W]Q7`U`@]`S8&)W]M#>`P8OT([SY#O:] +M'E>8[P9UML:N0O@.*X\>F,_0NOX\!J&?1&FOWB">5C/C$7K_/9IRO[[S"E0IJA#]"U=^!./O'](_" +M$?>![R2P31%JV>'[+/\0`4/N/QPT2CMZ@RP:Y:DE<\$F+B2[3N.I=D[OYU.% +MO*?)79K<*RUR>ZL9]+:W-C8['5'YRZCB6F60ZK_!\H\ODW&2:U.8+>NKDTZ" +ME2T8+-DJMI(?Q,4-.::/6N:U?/#1I`6BBOCD@`NCAL80YL]A;Q>(\RB&WX

JRA7(:'9RJ)29PSU=M&WF7GZ[ZE*JK8U +M"M&%@],LFX8O,+F7Q$,;[9X?/E[9811TX.R5$$RL18"<+P$&Y-RJ=F(M0:MG +M]:=P#3UM@+3ABSS!;@%L0LN`()_!EQ?(%+"A#-FU*@Z`-3G1+!'[TV(,:%I\ +M2&'"FBIQ_QF;,@\LIK+3`_;>*6/=.4B>XQ0SRU<[R_Y>/L<)GL5S1:/LQ"YF"?'5$##74>SPEN-<]Q]4K6Q#JHXO0W-OO5&^Z\M$ZX +M60$8"[4M%J*WD>AO=S.$M15.0`@HXH`.C[VS"^W)=D/D&;(%;`M:R"7LC_ +M%,T$TY)!<*DQD*PJ?J\9W;5&0K_R#P4Z@%`<&6:#4FL:OU/-/\3^FS5?W'5: +M[:>'O]]__?;X\.SI;[[<7[O=WN[W0_BWVP;BA]\[??Y7_87M_E9W>[/=ZWUV>7][VWUMA`7.MN]WO9OPD]_XP/^_LGW_S8; +MSBB*2F_UQ=5]@&9VFS1@7F$04$8B>NB#0&>'7#>FT;P98*&\!F;F[-U/FA'Y +MM<;31CINAL]`*O-_'J:WF&&7C1O/2C?/ZV]&%M"8-^FVZR"XAJ?#O;#Q-`3$ +MO;B?A!OAO-%IKJ]WHW"#/LTQXNAI,Z!&,6;*_+UFY167+TL`H:_^D\Z\<8ZS +M*+RKN#R%NR_(V[77IHE'?"E!0R-]NLZP"&4VVH.%)1M]N*4>*%T>\P;4"/C, +M3W1YU'^A^/2Y?EW$GVET^D39"/@]H`#M_,,%1F!?X+LN.D,:F"[@ZBKV_HKW +M_H&;OW"[\=)5$"AXP/9.@QG\EP'U;7A'-5;YLUD880%"&_Q:X +MJ1S-&(%"J1%%,IU-&K+`R-P661#3&P.[$1&0F_KY'*M)7.@`?CW2M?64@O?< +M^:#A;@:C".?!].(ZSB]!Q%&#T0T(`#4`H#5#05_H-@F=TZO@&[0J3=>CQ_3$ +MXV@&G^[HTUUP!?_.UN?A$T1)YSAFMV(7'F?CI!+K +M+Q76]S767PK6S_6/@K5T88Q9D_2)`4;?I_)+4(&S;0MG<4XV&NDWE!!''4+& +M*T2AST*/+X<;BQ$C6(H6!JJXSN3CI+&AWMX$8GG7?#HC"A&HC0CMTU(&PR6" +MX=*`X=*`X=(#`\PGPKH[>X^+QS!5S!)*P@:@9B-^VGS<#!]SNLQ4)\YPVIA) +MI*&V((^#81::\PIJ@`]2F-)5I%`BFCL?--+0(;*FT/D876VU>E'O8Y1TNJV^ +M_H`STX/A<9'/3^X4,<6)$1CY!QJ9"0Y?V-M3L&C"G>F4CA8L`H"\8#LO[X5' +M59VVO^S^+Y+_LCR_*.!UGR7\_6:I_+?5;V]I^:^_C?+?UG:W_U7^^S7^A.RK +MK;X`;O!-^/;TY/OCP]?P"?[_0/61PTX7V!);&>24V?LDSS?.X-DDO\*\<)6N +M1K]C.\($1\S2(IFE(ZRK,P+B_0W1'?CO_#'\`3)VPP\@N.%78%'P<3.AO_6F#6FB+ F-.=_.]>&GV^#'\-O]WE!%P//C?'&^61C98`SR=SH:F +ML/T4.,6MYGX1#"^WGB;S<38:%I*&%\%(']1O]YAT9-+S.+&WF,[@2(Y1LT^I +MGMA_YM/&!L:&#-1S27J=C"D)%XPKKYEU!8\"E\@9@%=_4=)V9/VZT\0F$+7]JXS>@$701_FWQ +M(.^`CP]8NMK:ZN]V^UB+&[YT>KL[O>YVF$8``NKH>,IR5_*DO16%VMF,:\HO +MTVG.91W9[FI-9J[GP1\Z\MZSD^-WF#AKEH+L.\RHQ2+FQJ9CJ[$O%MM0.,79 +MQZJUH0%O`>,,N"*O*?A\&U^SY8K2,V#?:.VTWO`L2=C4J6VP,$)AV9JQSQK7 +M#_W^Q[<%=?3`D(!L3"T0TC^JR@BO3\.S0385K\@^6VMPC<;5JZ(L.YMH!`XW +MVQN;;;(T;VM(6DD\E`M-;4P8/#_AKP/=MDU5+QYSM;9B#FSQEG-QT";V41*- +MN6@L^BA#KGJ`!Z.#FP$B59'?@TZ;@2V25X*#7HS#6>8R_=N5;E[[U +MY%N/OFW*MTW\ILYRCT_J)K[X2=59[NFCW+'.3M19N@='9,STT1\,2THTED%SD*)+`"`## +MF7JS[@R)12SD6$@!*M446L<38FV8/-9Y9]]PGQZ_+%$3J^V,A>1C[6:*3L4$ +MP7C*^RN$2U,:&&E"E1R1V(14L$D*,YMS2D^4X8$IJT%8:7@)?14:9W"+?9A0 +MV_FPUQ$%YD-W[\/Z!_AW<^]#=_U#-PKS/2':_'L.O^>![(FCG2$7:!@V0+=O +M&$X`WYN+3`!++`#^&Y=9@!;=;QN!0%BY:G2>]8C)-+K/-IOP?1._=0DD`(/U +M>:.'M.7#YCHQP">@3,#@'QNB]3'LFNL?\G4MXH>-D*C4QJ"YWL#G-Y!(T?-$ +MIB83^)&'\VU+5Q9L<(@'V4;(9D1BO39H$<-WWC"SWT`S>?@[)I,`_@?OV6`X +M>6^`GVV3@"T;ZIQ:N<:V`.L.ST[FFP5(?6.\I=I8578"WS0&4]$HCD:QOC** +MX8]D":@UCFT:XY@(,!L=6O`B#..'YL9FQG8(K4YZE@<9RC:8!8$\S>(&3UY? +MZS:U04M?ZU7_O2..'>'N^;*,&B!:M5Z++:_'*0 +MJR^PK,4%8<0>_=>S&8!ZWFEM1G&4XG_H"^KJ=L$T&:KAKLH@UI/-K$8T# +M7Z0&&T:+(9T�+.3)/NC_D"K:?;;"Y0T3W]W*`___W][O\J^C^SVT_7,9?H +M_]N]CO'_]$'M:'>VNYN;7_7_7^//I_$YT/#PJPG@JPG@JPG@[\\$0"!]P`9]'NP&SS*:8#(2CXMF5SC3,*SOA(MM( +MS]A&^N;JMF4;T7^V'673?-PR'W=#%H;5&WTH/G5=O(% +M;2*L#G-H$+$ZD;D&&1C"K\7SG3I3S9(G5K;3^%%-1DE_5J&0 +M5RGN?>O:5X/,9QIDN%J-:X_AA6Q^@B$&; +M,H>Y@5-V@SRP(\UPN-RXOK%I)4/[-C7.Q;%S81`3M#U?I-=46 +MGM[H=A@CNA'_.J!!\<-Q;;\SI0S<,AQ^'?$L;_Y^>]&T>N@== +M..:.HF9^6LD7B9DZ#K.4GPQF.74GP5ZJWYCB[J:>DB[(#&37]J:^0,M`%-ZC +MVG'%56))_+YYW/C85&NC+PAT61*MEZSG-Z(1MMIT[_T-G!A2=<9:F^-Z\[I) +M[KG)6QQJ(-*2,!`7UH4JQ$>L6HYIQ7%AX*N!>P.RKX&J`BF#,[U-1UA%R%[2 +M]6-X0(U#7V#*[B!Z0==Z01$]$8^I2O&"U8S95"<=.DPA:M50&@9AM1PVZAJ% +M:1SV%26"WK-NYS6?<$N`\WPMZ]94U?#'@9$G2583%X"[HHFR/LV/-J8W3L?. +MMTWU7AC`?S6U@`X;&J%&_&XS'48%=TQC#*:L1>6/S#@$6-54+TUL1"\@WKH2\)!*:7E:=O#%IS*/K)82[I)NZ/U^7UWL]X2C\ +M.8H=O&@3>L]K-`)7,@(R%I9#\FG6D8`N$M#-C4!ULR00GY^_P6=L>-O@_I=R +M_7[Y\S=B29P^#:_#\(-K9%KF1>&ZQ<'F2(+\A)1:#F9I<^9JX&/>U2+U;9I- +MK\I;-/=08!G="W_ +MM7;&UDN>QM'5+JLBV+ZNH.2':YYWI:H#T($%7%U09X$]A%5IP+33UJH-_#V6 +M]@*%+B&?S;AFN2%9J=6J`)#A/BXHK@XV8F7%QM[NX"^X_XOD?Q9./C?Z>ZG\ +MWV]W>I;\OX7QW_#O5_G_U_@3FL-;72\5QY>`Y<`:9SD@;T[5UY6`K/HL&L>9 +M%N/04[L7;LSI@O3AH7,>_EL[ZJY/TG_'7@NJ%QF)#:-D?`VBV21]NAF)+,6= +MZ4%6VR-G!+DV]]"/6!*ICY.I!+D21Y0PJ](T9(=(3! +M@FY2CF;EL]K`:_5_-(V.)?2CS!RNS8H9#(MF@;506C[:MO;17`G].(VR^&:W +M+60+_Y"[GN39B+66$=61XXX]>4R2+?;`$#&*^@[1CY%X7M:FLW$R7./^R^)` +M-7>QT^4RD6J-XHD0$=A^U5076:+H@/F$LN)%2"Y0C,:&EEH@XZ=H*/4<"&B( +M"B#R/`?9S`6+:@4)5QF3D`BK)PO$#]VK\?'KQRR\@J0Y=TEG]HTE:%KP> +M.^/=H^M:>]2*:8N\=`Q(:JG.J@WSY&RD17F<@K12%QT-I.-3%H_/6`[%J>*" +M\6UQE?LL=1=);Z6IR+LB@\&$98+&%:B%NX8-,2F"EY$9L&7=F1'A3:>/!T2W +M*#2H.Y..91A/,,)#-HE!L\'`7>H<:?I0$>H;?49(RF,]&"5;8G\=(HPYN;%4 +M@:A:)];?EC/I2F=0HXM%LJ;+"=-NAJAA%4I6X2LLENA?5W2YI;#-+]@P +M6RRU/D_0Q;;)[JYX&H]%1V@&4TG%%%?8)'VPL1DV$($*8^Q\RQ#`I=%-&_)H +M\RG>@8;H<,2!`OQ=@R\4BS'H+(W1!O[87&=@+E*[R'!-T)]*2BO]UU6DJE,Q +M47!7_W(BI@"4TQLC;'76F-8,LNL^3SFF-@N6E,@(29\:9+$31&_DGOZTBK;0 +MF723W5;7UAA4LJN:"XQ&5VUD>:#*4:=LO/@D74/.[]?]_V?<_Z7ZW\6@_9DJ +MX#+];QM^-/F_FY3_^U7_^W7^7*8^:']Y%1"CP\(OI@(V.E&[6:7[+=&L_%"F +M%=2K5]E]?V/UK49O<[2V;W2DIJ(HEG.O8'\CGQDB6J&QD*+'*4_* +MM`(G9E,+/RVY`.C`F(NSDV$0/RO69")H-4UU8<=86M7TETHVJAGC,,I1=SFW +M)H^BE:0AY#P]Z0`]IAAX"D2U$)XV7_9XE`P9Y.5'=7-BM58;H9P1OKRZ7,[O +M6Y9CJE1B0,"J!-%P'9Y902UF#NI*UG#148[IGE]=/Z;HJ&K].*K1;I5T6@6K +M^K@[O(0OJ,F3;%>$8&F@B_])G(9_21W9"\A:45]&77EC^]NRCC02Y>@S([ND +MWE&HJ@K16[[CW9/8+?Z9QC?MHWSMBW=@C_]IRC.KZEV,'9S[P0,HO:E^M"4* +MF,JTE-%8E;-'0\".`(Z=!;"%VY3*I@%4$=SVEU'K_KZT.H?V+-K_E?2_B_@O +M6?^SW[?C_ZC^TW9W\VO]IU_EK\2]XF4:8)&@1O:WI@(Z&B#)4-Q=>LVW8ZQ% +MDLA$_RFRV^0>1T:)%$/`!H-9'@_F(8G5+"NUPGTN?5XUUK12[23A>!7%OIF_V]-W^SV6*]:46OTO'U_%WKC/Y22%5>J61>QKVC%?W%5Z^(JI79M?SV% +MZR^N:/$2776K3F'B>U=2FV182WE:KL.Q;ZE*B8NX&\G>XYOT^N;+Y-BHZ>XI +M!4P%L=8K4YUN:UM_J%"G<)C5M"EGI#I]BH=[@#I5@KFE3F('L.D%W:;`K\=4 +ML:V5BA__0OT/>WE=Y)_K_EO:_V%SV^A_6U@+J+.UU>Y] +MU?]^C3_%6&6KR\K?U'U9TI/P\3JGG"4*@:A1I$!H.3=IF(#< +M03V&6%-TFVZMC74/L**B!UAM*[U`E;DXN(DGJM77JQ@[M'5V=['^2F\'BXS\ +M9(0J5=&`[-]*;R6U]8>P056()I@)@TGH$\R)B>AWSA[:MY*A;D">UW.=2QY5 +MN$_/M_%YK,']PT<:!WYED7I"R5=A,Z['T^E-U>A(^ +M5<"=L#BADB0(XPSA.TO9MTE1`!$LPDO,S@(60C^_/CP[VW]YN-=ZL7]\!GJM +M&`B(?`)1!5WTW=N6U+>I%9UK/:\M>_O(/R%("8.L7.EUI4H3*$*-XML]@%M; +MR7WQGB[+]H7B^59IBH%2,\QDO3'?(/Y!Q2B)]"^J0DF%]!]<@P"OT9,P,OZ# +MB!S3:T5B;*XC+N-TIE0GAR;D34,-8,GO%IG1C%*NB>1N[EA=;+\:Q15I2#45 +M"O17U5]ELQQ`:(1S$I]=7&;#^5]6_NOT +M=/\WZO_5(?EO^VO^_Z_R)X19;75%_X5K?`3F$,V)96'&[CCA4>`4*V;!1;G26YB*Q`X`6C+OQCI/8LQ2)?+0 +MRJBS=L*/G&84?GR:KZ_WE``HR4?AG*^&JH!9&&+1H[/_?GK>^(CIX$_".?RC +M@S@)#,V%=R6``K#1/J6KCX<%!2TLRND:5,B-. +MXP_)6.R2[=9NRUJ$5&S;@`$B6997N6VNJ[-IM5=NH=4T.D_@V>;3!HW15"O: +M'XM78VH9J$F2+VZR>[;V7U.?9)SA37R79KK"98;%VSA:`]L-DS-$]&:]OWIM +M.1"V?"S1.62`IOVD[IVPI>CL:?^[A@WY3+#^Y1!.'7<$GU@=LUF@YH`4OC6Y +M33=BT%WGU&8S,*4:T:H_]3P,PKXJJ\>)=R*AII]BX5;>I\KJE"_JI%#CA<&O +M[`#C0F=<1Z3'#H;?\CNQX565W1APD;XD78_;)HKDKLBAA%ND:H7D]Q=F5U&CR8%,#?1O;,^_0G<&U8Q3@S@N +M&.+W3](AUI;[)OP^&<1*<=`WI#K+K.<91(F=HF54B17.$0VPB.J8$.%VPADI&7EE\MQ6=IU)D(FJI<+YSKR8B]B$`"+0*T +MR-UGUZCH1.P>=3UF`=5PJ?"1]6@P=K8A:JSH,B,`.<4I8[6`!_K/F-)X'K2R +M_ZRC_&>JC*_,=ZQ+;7*X'VVGQB8ISS6_'$%:A!(%=( +MX"!4`EZ;%[)97O@%1H1)<'-QM&CM[NAU]B_HC4I.PR`0$,O`$F/1,(`,-`BA?7^F(U: +MX2YWI=]J]S:V>MM4D+@K^VA8K08W8Q8PREM=0K7:1O>[9`*(^-@JVLQV0EK" +MC.-S<_)^Z9?H1PW22P0<=^I*,TOB2S%&!+M\D:P'DR+-;^XKP7NIS +M;H0<.A`JS@)&N7;F8\LW/-9,:M+B\>JV>H<;L/$2U7&97E^[P1W5\1AP[`GN +M>`:L*J\$>*J1S<;A*;%\"O1):-=C0-!!.J'R1M8L"RL41(EJ^F4KL&6R8<.; +MYW23)K%)>0.`G<9C;5^6B:F*3O*U;D:#>")XTEI2C.T+9A-'GY!/''6:D7SJ +MUA>JS2\&,^H>*Q^`KN@"BK+X4[?Y+5VAYAD; +M?/-3/>2"D`%;LU4&''6-P6K=\3"38X35\:OKJU3;'KLEVV.G70H6")%FP8.[ +M_$L^2RXDTNH^!HDT0MZHKDPO])<%.F+BM&?@!G,K1RU/9GX1 +MBY,X$FQ-AC*%"F-8US:&><^K#6X\W>BTNKO][M96M]_>W=GN[]"<0$/>;+=[ +MN[V=7>!.N]U>ES.R*\;IRCCMUM;V=K^WV][M;FZWM_NJD56GN]W>Z>UT^IO= +M[9VM71G'5`!5$S%U?6$3(LD%QUO-G?(JE2<>,A9+P,03>`PU(0GL(]IAYM +M4TH1F-)IS.=X1-Y[$"3YZYY+2")-U?8L8E=CX[=HX)[UV4\2?]K`G8P(46+[ +MGXC_:;K;*26,N^W(#V5-`?@V5:Y$,[4>ZQD%06>ES9KGE?XCT;,Q/R^O?(P2 +M!KIE#/%_J`M#&7M3&C_;_=KH__[[']O[?5A?]M8_^G7O]K +M_^=?YR\@B7Z88AQPAC8OM@B)9!EV0VQ!Q-6Z-T%2NU1WIDG!`;/R.Y:E`[QE +M]"F?47P)WHGW6"&IT\2T?(_#XWA*_6M94HY!H9LD&.):#/+T4C<"*K*KZ3V] +MCT*NG2G)/`Y.GA\^4VO`!_L\3>_MEQ91Q$,.WQ.,G+:USP+TZ`%-^S;^D%SD +M'_REH2TLHY"&`=J9V)(E=E`ERKEXI#W3P +M@>Y#'VBO]```[?G)P9D#M$[5C@TS,V7X/$--Q?3ZLF7G4+D2G4%WS4XX%0;- +M#*4DLM*9:%@,\+BC3:YJB&*/)9D9]6-Y`=3X!_)I*!_\L3CSZ?/&LJ+HO#6R +M"[NT4C5<>2S;([L,7MV-H3@;JN>5C@&`%^DM*%!Z.+I&J3-T?8@[9EK4X#>I +M%IR-912W1CR_XG8VFJ83IY+IDE&<)C+R5P7H93C@=BSD<6K:Z*!M*@6&G'"> +MD#<)0-_3P[-WQ^-MU%LS&:/T^.CWZ/8:8M_I` +M;8X0%V8#XS2>C=./X67V$:;1:A%\#R1@([.X$Q)V^O%P7,QR"4CD!0HEBPRE +MC"P:&),*(C07!V`[/:`A>UWPTCDHKYK*9Y.I[5!82M0%:>`/G]P+\W;(/:,! +M],A6-JI0D!R;C*"AG'I+QLT[_A#PUVJIG^43_\/_[XDLL9O`E%H,2\@;]UQR!F!J"(_L>TB9B5T0Y%HVB*3 +M8-Y;]F&M`IW'V7BCC-*GR1AC&3P1!,9U\8@K#68S/HFQ1CCRB;-F1C!8JT,I +MPB@%OS4XUSFYV1(@S"*A!(1P>3KYA.-C9!TZ2-7G03GP>::Z[`0:B`A`50W0 +M/P7T7_?_\_:_K/\1UWOZ)74,[/';[]?J?VT=_[79[O7[&/^%9K_?A/TO.8FZ +MOW]R_:]N_WTQY'/>L23_H]W?MO/_G_[<*/=\;["7;W63GN;+W>[W?:FN4M_I;NZ?;FKM]/O],Q= +M^BO]KW!7I]7?W96)`!9N +MF[OT5[H+")!,I-_O66/IKP%^ZW=D]OW=K?:NN4M_I;O:>B*(Y'"YXWT-_NO_ +M]G_^W__K_]KX7_^GR_^'_3_8EO_EO_[KO_Y_\/G_#O_[?_YF_^+_^[_^3]/_ +M]_^N[O]-\SGN'?SV_\+K^-F^KO_V_^-?Z=]__>;_\YO_^7_YGWZ3_M=__>8W +M__-O6O/_R\^M__@_I+_YU[5PP?DW^L5GXMBR\]_!F%\=_XOVOZW-[:_VOU_E +M3QFZ\21L=OF\IF.4G+:5ZX"JX#N=^C;@YO[6)N#P9O#U_/^CGW\T)WP6CBT_ +M_U;\?X?X/US[>OY_C3_[_/>VMLWY[[5K&W4BIO=V=^CX?SW__[#GWS8Y?A:. +M+3W_7:O_SS;U_VQWO]9__E7^`FF3A2>^M=OOPHG^I`97HBYT.KO!U_/_CW'^ +ME7?CLW%LR?GO=/K^^=_J;'X]_[_*'R+D]DZ?3R]\;&]W[,]NR$W%[WRVU,5. +MJRU8KS[[`YC?^7-`1[C7WUII!AO6[QMF!KT6X$OM&YP!K!G*9QY@M[M=^X85 +M9K#9VNYT:]^P`@SZKH8+DPMW6;IOH+MY' +ME*W,'A8&JJE7MKM![=J_[O]?;_^7TG]R9W\>C5E*_V'S#/WO(?WO=[_6__E5 +M_KXL_?\4RF.?_T_$?7/^/_'T?<'S_XD4R)S_3Z2!UOG_%"Y<0_\_D^R'NWUG +MX*_[_[>V_ZO0?PQ>^AP:LXS^]]I=R_Z_R?:_K_4_?I6_"OK?WMKQOE:=P8J[ +MJGB!=Q1J.(*'KG5T0;USXQ-F5J(1WB&L.245\Z^B%TMF5G]7%>U8`K/Z^5?1 +MD26[N7!F)9I2L4\KPNPOPU\ZG>W`>?W7_7_@_B^B_SI0]3-IS!+Z#PI`VY?_ +MX>!_I?^_QE]=U3>T4^YL!:L66G?^MMGW^^QS_\?7\ +M_RI_M>=RE\XER&!=Y=&H^L.H,+(/T@=SD%?.A$4I3[PAGT(!-OO;.\'#4E_U +MT>K"7!>E>>+:^["X76?MI>[M'Y[_?V]K^>OY_C;^?51)?,9V/DC]1"9U1 +M\N?@YVPXQ#(GMW%^#6>OG8Z#GZ?91+YNM';H0O)Q>I\.IS>@*?35A9L$JQV% +MNWSE,H'[_Z1>\N<`[DFG\*+3WYV].SH__!D0[5D8GDE.)UGX8'OWX]@PF +M$<^F-UG^I]/63ZWP^SP>?X!W__PSG7=3'VE_=)WEZ?3F-GR99[-)>#P=MO"N +MG](1W%]DX^!5-BN2*/PARX?Q.'R%171.LWB(-YU\A%<.H_#D]]UPY_EI%+YK +M_:X%+QX/@Z-6^'(4#ZE$$=SY/,$"0[>2+_8:J^?YV']YTM@]+'(+4]2?X%Q,P"#0`HO@2 +M,^4&TS_]A'68QMD,"_!,9I-HPQ!!_5>J( +M:V@I(:X!H&TB.WL: +MHWA\/8NO81H)Q8[`35<(8II2-IG`G;,Q`N4R`[P!:AX/ASE6"M/3H"01'INS +M*F@4@+G.%.$>KUF@2@:JTB\QU?C&2L'4BVLTE]0Q!%E19(.4)%QNQ?SC6^[# +ME1=^A;\][0.]_+A):^)^. +ML(#;D#-0_AR\YM(W0LOQC*DDQJ(.8P+<600*8`9N_+/PT:-P_A]_^GF2I[?) +MGX%'7C4^1O-F%/X,_S=OQ!@(-K^(\3:JOA@\BJ/P8Q1>AC_#$'_Z&4_FZ9_Q +M]CC\;?@1_G?Y*&P`:CZZE._QHR9MY*-Y%%Y%`0[F/JH^_ +M`))0M31.TI5Z9>4#G7RE+ +MJSE__BCOP7QSTQ4MD#IECS[BXK"Z+%57).*`5`#7%A`2QQ2W5Y=KU7J +MXJD]I=8,NO^LU%CC%D)3>4G@:`$(+EDNEMGBRLDIU:#SWD)'*)Q-N66#>6?` +M"U<@$2L$5F-.QS"=6S.-V^06TX6'":!FQG2UA5EZ<$Y92>A24[4ZMJ;*_R$Q +MM(@%50J,8%5ZF)XT8@06B/\C8C(>CI(2,X-CJ)/U`LW'HO*)&R?WP*NP?JA3 +MQXYJ.?*19M0<(^\)U#PV>3E@-`UN@)`%W-R<\!^X\@;L%60A//&/C%2P>R[LB +MH8"=^N47*LTE:;,P(\9_N/6:.\$`U&'*`<#OP\]4<^WQ8RJ;3(UVIKH>+;#P +M.RX/',92)A?;/TZ1+Z6XX?`NF+@608++.0V.5(NQ#7M)#D983983N[%H)N:6 +MPA;=9)0KRV]C%%*<0TMO@69\)0R+L%`SRKH`=U>^@XU#<;=@SH*U=S,0XZS& +M]U2=``X_%21]%BA=`^!^"\0.1&K\]&^-M/GO!+^&A>_Z54U]E[YMX4UX5W$3 +MPVWSGZ7#G?[Q3HV@=@-^@I',A(*CL1QH+!\[X/KA)'UP.C5)'UB0D"JL2FLE +MIK%YPL5$/VV15'C:E+O`A&/,$`88XH$0?`]6`D7=4*9&AXP:E$:M@%UY-"DJ +M*UNLBQ@BP0H>@8CX*`K_F.19V&!$!'D4F5^#"X,T<1XH>S2`%^0I-C^*N=JL +M8"C23+1&F8$#9_N4\&5I(#AAEWY;>`K#.?S!/HFEM6D,G<:76*7VSW\:_8_! +M_QC\.?@7AN&_:!""OOCS#8ITO%8+"G"KO.!GJJ_X\T5[&/Y+8"[*$'0=AD'@ +MZ,@?AYW&6,BA/D/_?IU*/G3LH%W.@ +M2(1'%KL!T6J4$D-Z0#J-ZHVMU=G9N;6@F9^I;59+'P^`EZI=IU? +M7Y%4C\4F(I57SZ@66"X3%#KX-]-&0.TUM];]\[_=3/]=70*=\Q*F=_MGT1>% +M9S#YOU"NE(J"KXCKH_FS^TF5&?4;ZBRL.2.>%[?DE/RU3+V$I7_?*)XTC*F*VF;+<+K\K'[`+T-KS(R+Z]'6W6<5IJTH2[O\*:Y*JVK2FFER!4\"Q5.G +MKV(E$!)4(1"YK"&\BK/FHK^;\I,JO*?1IF:C5]D48-MH,"EM+XZDWKM\'&LD +M-95R^=:.*=]:.8!TV!`Q!NFI8?I\3VUI7("^JHM+'U6%5?C2W&L\A7^>8J.] +MNLY.IEJTC*2*VQ>RZ\)BK+'JAY(>K=014\U&E09U1ULX"C<'PW]*3YE63-Y/ +M,IK?S4R/^I#S"AN"Y4.PQ"JKMNJ@KEI]E@$:&5@VO^Q$N#"M`I?N2TH?GH1V +M0]K0Z<#[72BU2:F>K+YC<343]D_'5Z6$AJ(&IV(*!A +M_4.ZSQ;BL"$[GH'R='^^0"$0%;*"]#WSVJL\NPUP6'@UJK&EEU/#EH1KEEDR +M"5GE!C;71JN)PT'PI;`;&>G7I+S1].$M53HF]B4Q7`GP,.'&>:1DX!L/?W]^ +M>/IF_SB,IR`@7\ZP.BZW7S!F3;+*!O#*VUDACU(->RF%K@6I"%8$XA&"F^HB +M4<! +M>12&Q6X\IR_V#P[#RU$V^&`W',4[5-,_M&C,+I51@]J0DJ!/G4]_MEJ?&ET= +M\(SO,Z:TPNHM%7/+'0!8BM#.;\GS@.\EV1`^HY7@6\290#6@B4W;(;4J;+RQ +M[_9'Y1W`O4V&7+;I*L6F!.JFTIP!+-B9R+J$@V+C&UPR=4O2%('?D"<+%J5: +M@>379(`.#TY>OR:Q>ZQU6)0S;:TG"L]_OC@[WS\])ZC"E\,WS\7T.;?LIF1_ +M,M;!1_\61Y?__HCL4._5`-/J7FRD!K:P(<4A`."`F]1:'6E$9D5PE8V]L*37 +M6:YH!O4?\HS'EHTFL:H,XG!V9XQ??DG8Y&1@9C<9^^47[#\'JT1N#Q#2_7A^ +MOL`?"J3&5Z#0**4`K8!)_F=;ML!2VJ!P/\58@H;]?&06VPP?_3Q*_O.1@083 +M2#6<;I"#.E8K_!YMHE?Q;`1R"N\_-RHI^*A1L4=I5F2!))#F2PUNX;3WR^O' +MS#;-R%EJ8Y?1S'B+T>`<-%[)[F/KA)\O2)[7 +MW8&\?L,-W6/X?\,N+?];2_3]<2:UQH-23XW&X>GIR>G/%_MG9_`L/$C=B>%) +M+F9,=OI;[,\&/"D'"A6P18;[R121&-`_L+=0'PRVADO!.*`P#U#^SMY]?WKR +M[OSHS2%O2`//6'3.,(C>R[_G>(HBO<<6`E3*H[Q/$6Y`1`N6]4:O9#P!7+-" +M[@<8XAZ^.6_`M$A@QQG9-U::F/131V_H(;6"D*9N/[["P[)L>>KT.HQU\A:[_.T?^Z,* +M`$.$H#Q\?/+RZ`#OK'O&`;1J?[T"W.K&D[VJ%9'.'%8"9XGPQQ>02L=RD3/+ +MV.5+GBQV"5DM%%V7EK3>(287EI@R';B)`'A9")8+*7%XT&X\2QJM`;QV-&Z;&M]8*WTJ$!/-7I+K41!0C +M1-#6G2?/@FF6<5L[ZA6:3(B;6M5$,V&D.V7"AK +MXDNI6Z#8?50Y^!?8'@A[6UKM!V?E9G/8$P+>0V'1U`)OF$RI%U@U8PA_'L67 +MR0@O]?YG9X=_7AH\0L^VN9D,^=X`;P"$0K^`20"!D+_)82FC[@- +MB\G^T9L*PJ^%:\-L7KQ[O0#F(3WT"JL895'A/S3`R_,`RB) +MJED'YI*_MH+.6)+A,K#<);&YJ]M;;JY>%I!6-13](17YFM +M^!RDI(+;^M2[DM/^SZRCE[WY2AS@IEOSH1^?9.#&71J'CF#87(&1;0(U/'U]YDTFTGTJ +MK>:47KM<9#B!-<>J/G"@35[%N=(OG$:6+RBTR#`6A^PK;43:D>+^F3E2^T`, +M3*/>=9>))?4'V&*/._MJD0IUI?W?5T%;13=3XU`T(]"K,V[U::U,5$!KE"FU +M#$$EEKL&,O.R;KB/BR`#?,KOB&(N))B;M033$JL99WATII$`$?X:P7OET_F% +M_OP)Y-$34?V36WL2]4RJQZE]3L_U4^1+0X7,,"M3`^<$ED@!+/C\Z.S\Z.!, +MHXO&R8+189+D%*O#M@,?NVNL)+94V$?5_QSG\.+G"Y#(CT':9J/'PO08M\=W"`NN3A6S491S[S/,T^KV>RQ*N,D\SQWC=_Q@&!/)H(#)W2;2NMMN#&S)6&2U^N67$4AZ:!#10RL1 +MLE!F/8H^%BGOEU](/'K\.!#7JY:M\08R.6(P4X9J_RR=IN1J!Q"AMY;-$T;^ +M;@6O?KYX<_C[AS*"HO_C-Y@@;=`S1_O64^ +M17ZAA!&?=!,MML@U(.L(U*$I18RHN6G-.R!#-!GNDX(._2$+9R#ZY1F:#!*% +MQ&+W%N1')X`@ORVF`**^U8;^E_NGW^^CB'EP'!.>:::'&H-$ID%=H]0 +MMF8N3%H$.E@3.QR,N;6/KY]Q/"B=-=/R7LWT"DY4P*$KFBB.YW[[8+1"4D-D +M^C%/-BS5CX)IE44\H.?-O(EP85BGNW['"^':[-E"8D)R74^$=R]V;Z.X4.%( +M'#G,!)I<,R-D6-)MG8),K_S=8&'7.&D\AKO%WJN8^5X4DG*/.T`.-^#D0Y#Y +MG/SDV(?P +MNT@6)?M02M&0EHT(YP8/``Z6X$\(CVXZ;AUNV#D_$H6U[Z8>?9AQE0<%+6!Z,\`XP_7P3 +M`J.7WJ0O9D)`^FNQ)^=4E[0&PPH<E!>@8_9I?2"*+@BRULRF4B7,^!- +M(#ZIQO#LO?&F4ZWJ!X;^;?MF:)X>"IUX!FV3M#4YR7=`CSP13!#J,"CMSE^D +MX4?*$`('ENS:@T0[@BFJ.QA@+N!4WTI@,/QB!6T6]1*C;1P'U.?))'@ +M/:(^+2?PI%J1L/C:`M.1PJB=5F`S0AB@<%)80#(94*NF(3DBC4+S!Q3#6+VC +M-)=XKE0Q.\/CA:/-$H?`V9-ZTSAW=$?SE*.B:NU4[/J:WU(;UX_")/$7,Y1S +MU%K-H.R&>8@[(S:0A\.HYM,*]TLI5C[K?8J)21[WS1-QY+""]5ZF)G3%C'9GE4-GX8AGW'\O_S#AQL]?.>M?S*:_$F== +MH,[15@767JU.S"P,\$F9G?K+Z6'/=<:G%1HFYO?;^`_4=(_ND,13JV&OI,+F +M.H>,.9%),VUQGVC.04=?62*]DBEJ32<78\(`OVI`W3O9`<>:`;#>P$FC0`HF +M]C.346$?/W;,%AE(]YC)!4H:#XHVQ-MTZG:2;7F>B.?Z/3^JP0$6^R,B^>A1 +MM#+`N:&>A(O!NAY]]#*1Y\[W_Q@_:@7[W&@/>ZS"!_*&S%R99 +M4:1H^&=K)=R)@@.HBVQMC(&K3=F;/IH[3DY>)54"D$A")UT)05;H3/L@QM0_ +M$KYN`2=(0R&VA6\;9).Y(O[4;5NE'O/@\*)IG@ZFHB!5,(D[H\I;Q@X93(:8NSL3PEG+PZ)E^=)$C@IGNP5QVU[IK./X!<^.T1H +MZ)NR_,:4CYY,TT&039)$\ZED +MI-?$,%(!@EV'#9/3F(XW*+$)^1,:RNDH#I/!*,Z)5P=R?G7V +M*S?:I,5Q-^IRDFH8-A1FHF`<'+U^>WQT<'0>OCD!+JI0)H&3#K@/TYO.K5)F +M]&J0+)HXN&"8WJ6%?8PYGC)/FW2IG.`2.`J.@`\OWOSUP=G$*A:!!K>!.:6C3]H5[O +M_UZ/D(W+BS+#?*O)FWZZ"%\?O?D11*J`#>)Z-_10YG'$=D"2$CU$_+3)5<#D +M2BE-8\![.)^%4;VL@C0.F3L06G@&W`W`!\))$!M9HA(Y%1[4OPR3X0/%&?RI +M(EN3^B@NN74+FI"%(?DX2+APA0!)A=/;P"0@1@)4MO^_>QT:`A.P'Y*/AK:7 +MDBV:X\ORY"JCP'R*#ISDJ4K0\*?=HH;(G.+,9+QPIJ([S"NV@.Y8H";L<57A +MUAA#/PZP.H."&L=0_>0E39.CEGI9Z](D:ODPJ+27+R2AX-TX_1@DX[L4I)]; +MSLM]IE2Q9(PUI6!,2:N6-U@2F!)XB7GJ?%"ZYC_2'?IW=X9U][87WHMBOS6U +MX!R%;)2'360>,2'1J%:L)I+!O.0,<8Z<&'"IM.2AFE-<[#$T! +M"ET]0`0?J0&C=EUS+8NG%8&%-N$O'2)7W>%CU>(<(XT`-.)0QU0"*RDZNPIL +M?$:?L9&U9*RV.U:>W&9WRNBF$LG]&B0:>F08-(G@0G\%>,2F8<_2X0RHDR6] +M\^[1K:23I!(G2>J0`!?4L%LNW\!-SJTC1G1RF)%;@=4E-9H^VI'E)8II:S=B +MX)MCA3R!.5BRPQIV*B`49='"2"P:3ZR:+92?38R?7F/"(BEGB)8_SL8H$Q)0 +M[C$`G],-#.L)0"]`DP^L.+V&P\NN#@'"#_$@NTQC8H2/KDA>G2J:6WCY!@"A +M<4*J#\KQA0@@6(#JCR61=LJ92];]5#<$US,/'LW_X_R/^"XEUUU5C',@XR2E +M8>CYGR_C_$]_1!).P!5F-@\?_8Q&/X3(GQKFMB9P`TR]P5PP;0X+WB'236<8 +MA"LA+5;.O$$/C1CAPP`8]?9(594YDA.//$0^[]TTR4NL`P[QQ`+);'Y,4ZN%); +M6JA(*"PEJC:*3([GF:09`O!5C1.$-LJR`:G(G&`M],P]4$FN3-)JWXRZB"K0 +M6!UN`J_U&Q&91M*Z;D7,*:7](SXFL?5B+L&:@/OD-!?]WS;UL*V@$-@'_J%" +M)L7:Q(!WE^.I=,R,84FL5FNO;*#-450ES11-(^L4L(>;A.96] +MQ97M'O'D50&(*TI)8EPW\&V0`(,LFI1;21H`5J:8&TH`T&-",:5@2[:Y +M)%(/3D@P5KADCDBCMX(#D0%!#0FTZ"7L[F[A2 +MAN<5(-Z?T4L=/*+[:"VW649Z+?"#478/E`;TC#GG78)\^@/=1#%1G'^57+,. +M2>&@FJ=)J7"+EQ=LL;`M(((!MEV24`GG$NS!'#/8"%[\/BRN+2+R#]B5NM/& +M2H$_AV/XTHFPQEJBOT.I>(J5C*]A4^`XM-C&BPD?.7("1:H+SQ:L2K@!*=-'+58V`I:, +MA<;JF!IM3*HH&RE\BTR?-V*(D#!KX+3L9V.N3]$TJ,"BD&,8"4.^2#_*2/)# +M`TX7SO1R1O$D`5$C10A-E`HK+C?I4,P-QA-E2KW0P*2XA*>(I5&O4")A5*+20"0E*<`63"VG +M,OU"D5JEE<($WE)=WADKGK:-4!??L15U$R.H*@5*KJYP!HJ)5V8HT$JYRJ$U +M2R\\Z24;Z6T[^I%&W,@BRU'9GD].A4FL=!)T/YV\"3%'AHN.9AQ%)%L;.PL=(Y82Y5QXR*P`ZXND^D]ZI9&"&51YD?9E;9W+"*+DT2! +M%<]E*>J`WA]`PV;W/%=3:_AK;:JS+Y"11'ZK%&.LG`(LM\2T-_;10B,V)9%/ +M,668)`9<1%$@YXFOT!:-'1>P$C%.89!-4B,(EV#/\0*H0=_&PX2HEK&'80FX +M7#5\N"$E6SN0?_D%=+P/#JSQS3)GHS<&=GTZ$YB'I`NW!N^22=G`K-B?8-^D +MWHI%%A=ZRY3#-B6X$8"6=(DD4`P4*(NJHIH@KP,8XW&"$5`6#2]4O**1PI36 +M@YNOJ@7(WNGM(JK-48:%\CW=):8TO1W9E9%F3-4DZFHL2PJ,)4ER[3>)T3/Q +M;E=B+JX>1_08R:BT*@Z+ZE<$)C[$B@V@R$A$,JW$LDU-NGX+A^"8`RS>/$XV +M[#LKD^:QS.:4P23OUE)9.B;4Q)!(H-3#H2.I<92DG(X&T`7@OH'EA&IB<`:L +M\\#X48!#H+:*$89.B6L4A69*4@J5++41SE!>8*EIQE)31[X9L>H<+V^`I+1Q +M_F!`/&4L)(8MW8HAZER&%;> +MI5HG\;D%-0M5:1?6F$[3`:I'&K%Q!][9XG`'MO'=?W1YV][Q)LJ63DF@_S?X +M=O[O^)Q=S-!]B]@:[)?'?'0]XY6%+_!GS%BU0L1@9)?@;)XT\?4<4$ +M6?H13!>02ZX9)(,%W>$/UGAWJ\SXHSWC=X".'P$+[QI340L^,B;+ZVH@Y-3D +M^^47A7<%I7%DM^&CZ1Y@%E8QGNZU%5[;-*E\!FUI7YT2FAW\[PE.CX=AV5I3 +MJ8$3`H?5BLAA@9OGTT0+ON\0LG`3)]N@44$-,\Z">'@'>$GISH5;"%V5?-70 +M995.YX)(?;]'/X,"-TS^]`X!_/,HN9HV0D%D8HA__M/@S^$[K))X%Q(D^6KX +M^LF2]@P0MQ@E6I72Q.XQ)3I#8X.;>6^IU@*M1G%&H!A;N +M3>XX^!NF0('G6CCYY1>IB`GO8B\LE?J@,343@2=(T;-F61FN*>6/29!E=HVO +MA9>Q<$UB36&*F!C6;$?<^:]62]IGH2$9@0:+41849#=#_PA=UB&<1GQ3$8"! +MAN',ZW!EJ2`-6Z5+$!P>)@B'+=6R6BE,\NT!6P'EU1+`*^ +MZML0_?"JHA9,&Z#37 +MUX$#;="G>:/;#)]:KW?J0JHR?E9=2+5H%Q2*]-;!PKU>`MS"NHU5M2"_^?^W +M=VV]:>10^'U^A2M5`KIF`DDO2J-(.R5)B[:[J!LOM/KQDZ1P6\7\ +M!`;1)__G`^-Z@=L&&M$C6+V/972/#`5E=PCCCL..7=X+VT`\A%TD$%T>@:$A +M#(9!$>8MY&)[QX;OLCLDHHU94%1M<#-VA]H^H&U[M-2''(W"S@CUE5951H<( +M#X[TTO$A4M7R:3D1MU78GT_Q"&IWE,(L'ID*-\I>4#X0J@2G&S,LV5ZM/T!]=-J"=_9`#BNC"L^?MAR +M?=(#CZ#P?+K./D);"Q*Q^O"@*$QW,WP5U&$34*U+-VKX0K`Z7MMS^K]=D)D5 +M9&8%F8D@,T^0\#W-OQ]7\HJ.2D7JDXS:_X%]55&.&9&ASN8K^D/Y9`G2CW!N +M;O"<\@,5W+G0'9BE?.\WL)(JG#$/[[-<"K7Q4DC%U;$9_:S(K1I0IH9,H6XB +M;\-,MTML4'&$;(5,?S)1F1/8+4[G"W+`WCMDR8!O$QQ%P)%V[U::52OG'26[ +MQ#9IXHL1*%W`YFY!_^KHN1>@>NX%E?5#84L'I"J)'Q2!LQPNMQ:$)52_1EZ` +MFQ`.19:L`TZ,"+Z"1A.85,O5/'88#8L"9;H"#K6PLQ?1@M:8*P4<&JF_+$UX'#R`06<_P3L +M#3*6F4!F.H7J!FL+]R5?2N";FSAIP[9_F@H;!5+6H^%H%F=?\/^$L4KIJ%NQ +M4HI8N4@]N@N..`R/3E3,[+&V>7]\M&^8Z`HJ83]Z7UJ(4:`K-GTLY(/CTZ9I +M'LXY)_N6<&1R)LVE5+*@O&J.QA3"X>73T"D3.2ZT% +MW8OTJ1BY<1!?+#^&<:_%YDTK.3LL[L1%D5FT!A/8AZ%`9QZ4'4\PO>'(2[GS +MXB[A1']$G20G.0@V3^"+:CD66[A',)QG87&@31*/NXHVPX0Z3#'&(A6%%5R9 +M33A(*8J6TTD65?GS=SSO!#HSCF'%B$$%:_;\LU&`ZPE3&L'6*8\ER^L`EXH\ +M(A`@W"9`E_5MPGQP0("_DO>7I+"4Q4XB;Y1R`>N_6N*!@@A-6W3CY]QX]S2: +MO/E256$TZK7"N14*--J>D1UO,M4,81LQ7T$EC,@_.6VI\\[97M,/UIC&L+Q; +M&)!JG?GA0;,0M]_]J9+V5_7UHSH[__PWF->J)67V7C<:#3YF1DO;A,!=T>J& +M,(S:'B4@N/R-0"5=FP.9K#"(0Q$RF&"W%*.(*!J(P#T3QRW$++3A:>%8\'3R +M'1>C[';$T1!8-4WU'GL=U)/!ZW."+^G%>'U_1\>,OL$]]"8R0,-/V:F5GTH3 +MI?(Q/HM59PP:!@N%CGH]"9F]A39T<(M-)SEO85=8_^-VN4Q!7@,YL40"E77Z +M"ZW3PB,82>[0'$F(,:&H',T_W*]WFIH2=L:8Q',9ZX?3=6J7K!,F08XI03MQ +MHE7S\!#L_BK%-MP0X((UF\_6UZCIP^6"WGCDH>'Y48L]T5#&OB";*9;VI(,I +M9!)?R;XXU)61493,.$=J((4.O:VP[W??X!V3S&9(Z0Z/4:+4F/M/>1*SH6K> +MJRITYV5-1P>O#^H';UX%K>04AD\90N4-8<)#B%/IU)"&;XPE-G2QB-7+9OW5 +M`3L)6QZ96(Z:ZU*\>ME6*Q55Q;?JY_A3K!+8YJ_2:4TZ?=GIM)/DGONX#YV] +MG-],!U&'_*48F:=!//#[2E$-]3[^`!*Z6N-D[O5"P;**L/*],\[N0//RM[@R +M(UL/"B99!-A\MS]MF_TI]AU[1`QT_4E,CYW.$'F%+8^:C0:T/>FG@ZMK;O.; +ML,T(T5&;(^#DU?&<].+ZY25\4.*6HC*@7])27P* +DTYWO>BE]=^/__QW_7YU_>G?MKMVUNW;7K[G^!6O-7*8`$`0` +` +end diff --git a/rksuite/readme b/rksuite/readme new file mode 100644 index 0000000..b0c3581 --- /dev/null +++ b/rksuite/readme @@ -0,0 +1,115 @@ + **********************RKSUITE read.me file ************************* + **************************************** + + + RKSUITE Release 1.0 November 1991 + + written by + + R.W. Brankin (*), I. Gladwell(**), and L.F. Shampine (**) + + (*) Numerical Algorithms Group Ltd. + Wilkinson House + Jordan Hill Road + Oxford OX2 8DR + U.K. + email: richard@nag.co.uk + na.brankin@na-net.ornl.gov + International phone: + 44 865 511245 + International fax: + 44 865 310139 + + (**) Department of Mathematics + Southern Methodist University + Dallas, Texas 75275 + U.S.A. + email: h5nr1001@vm.cis.smu.edu + U.S. phone: (214) 692-2542 + U.S. fax: (214) 692-4138 + + +RKSUITE is a suite of codes based on Runge-Kutta methods for the numerical +solution of the initial value problem for a first order system of ordinary +differential equations. It is the result of decades of research and +development of such methods and software by the authors. It supersedes +some very widely used codes written by the authors and their coauthors, +namely, the RKF45 code that is available in several books and its descendant +DDERKF in the SLATEC library, and D02PAF and the associated codes in the NAG +Fortran library. + +RKSUITE is being made available free of charge to the scientific community as +a public service. It is expected that anyone making substantial use of the +software will acknowledge this use, and in particular, give a proper citation +in any publications resulting from this use. A suitable reference is: + + R.W. Brankin, I. Gladwell, and L.F. Shampine, RKSUITE: a suite + of Runge-Kutta codes for the initial value problem for ODEs, + Softreport 92-S1, Department of Mathematics, Southern Methodist + University, Dallas, Texas, U.S.A, 1992. + +The authors have tested the codes on a variety of problems, computers, and +compilers. The codes are believed to perform correctly on problems for +which they were designed. Of course, errors are possible in a software +project of this size. The authors assume no responsibility for the +consequences of errors resulting from the use of this free software. They +would greatly appreciate notification of unsatisfactory performance that +might indicate the presence of a bug. Constructive criticism would also be +much appreciated. + +Future releases are planned that will add capabilities to the suite and +correct any errors that might be discovered. + + ============================================ + ============================================ + YOU SHOULD READ THE DOCUMENTATION CAREFULLY. + ============================================ + ============================================ + + + =================================================== + =================================================== + THE EASIEST WAY TO SOLVE A PROBLEM IS OFTEN TO EDIT + ONE OF THE TEMPLATES PROVIDED IN THIS DIRECTORY. + =================================================== + =================================================== + + + Installation Details + +All machine-dependent aspects of the suite have been isolated in the +subroutine ENVIRN found in the rksuite.for file. Some environmental +parameters must be specified in this subroutine. The values in the +distribution version are those appropriate to the IEEE arithmetic +standard. They must be altered, if necessary, to values appropriate to +the computing system you are using before calling the codes of the suite. +If the IEEE arithmetic standard values are not appropriate for your +system, appropriate values can be often be obtained by calling routines +named in the Comments of ENVIRN. + + ================================================================ + ================================================================ + TO MAKE SURE THAT YOU SPECIFY THESE MACHINE AND INSTALLATION + DEPENDENT QUANTITIES PROPERLY, WHEN THE DISTRIBUTION VERSION IS + CALLED IT WRITES A MESSAGE ABOUT THE QUANTITIES TO THE STANDARD + OUTPUT CHANNEL THEN TERMINATES THE RUN. THE VALUES PROVIDED IN + THE DISTRIBUTION VERSION SHOULD BE ALTERED, IF NECESSARY, THEN + THE "WRITE" AND "STOP" STATEMENTS MUST BE COMMENTED OUT. + ================================================================ + ================================================================ + +The distribution version of rksuite.for is in DOUBLE PRECISION. A REAL +version is also available. When solving ordinary differential equations +on many popular computers, it is advisable to use DOUBLE PRECISION. However, +if DOUBLE PRECISION provides more than about 20 significant figures, the +REAL version will usually be satisfactory, provided that the accuracy +required of the solution is meaningful in the REAL machine precision. + +The values of the coefficients of the Runge-Kutta methods are supplied in +the subroutine CONST as DOUBLE PRECISION constants. Some of the coefficients +are given to 30 significant figures. It is likely that your compiler will +round these constants correctly to the nearest representable machine number. +If possible, you should request your compiler to round the constants rather +than truncate them. Your compiler might warn you that it has shortened +the representation of the constants. The warning does not imply anything is +wrong, but you might wish to take action to avoid receiving such messages +every time you compile RKSUITE. + diff --git a/rksuite/rksuite.doc b/rksuite/rksuite.doc new file mode 100644 index 0000000..73795e8 --- /dev/null +++ b/rksuite/rksuite.doc @@ -0,0 +1,1194 @@ +************************* Start of rksuite.doc ******************************** + +This document describes the use of the suite of Runge-Kutta codes + + RKSUITE Release 1.0 November 1991 + + written by + + R.W. Brankin (*), I. Gladwell(**), and L.F. Shampine (**) + +The authors would very much appreciate receiving notification of errors +and constructive criticism of the suite. + + + (*) Numerical Algorithms Group Ltd. + Wilkinson House + Jordan Hill Road + Oxford OX2 8DR + U.K. + email: richard@nag.co.uk + na.brankin@na-net.ornl.gov + International phone: + 44 865 511245 + International fax: + 44 865 310139 + + (**) Department of Mathematics + Southern Methodist University + Dallas, Texas 75275 + U.S.A. + email: h5nr1001@vm.cis.smu.edu + U.S. phone: (214) 692-2542 + U.S. fax: (214) 692-4138 + +**************************** RKSUITE Overview ********************************* + + RKSUITE is a suite of codes based on Runge-Kutta formulas that solves the + initial value problem for a first order system of ordinary differential + equations using Runge-Kutta methods. The codes integrate + + y' = f(t,y), y(t ) = y + start start + + where y is the vector of NEQ solution components and t is the independent + variable. The integration proceeds from t = t to t = t . + start end + + RKSUITE contains two integration codes, UT and CT, and a number of + associated setup and diagnostic subroutines. You choose either UT or CT + and set other variables which define the integration task by a call to the + subroutine SETUP. UT solves the "Usual Task", namely integrating the system + of differential equations to obtain answers at points you specify. CT is + used for all more "Complicated Task"s. It is easy to change between UT + and CT. All arguments accessible to you have the same meanings in both + codes. (However, the length, LENWRK, of the workspace, WORK(*), depends on + which code is being used and which capabilities are invoked.) + + The distribution version of RKSUITE is in DOUBLE PRECISION. A REAL version + is also available. When solving ordinary differential equations on most + computers, it is advisable to use DOUBLE PRECISION. However, if DOUBLE + PRECISION provides more than about 20 significant figures, the REAL version + will usually be satisfactory, provided that the accuracy required of the + solution is meaningful in the REAL machine precision. + + RKSUITE requires three environmental constants OUTCH, MCHEPS, DWARF. When + you use RKSUITE, you may need to know their values. You can obtain them + by calling the subroutine ENVIRN in the suite: + + CALL ENVIRN(OUTCH,MCHPES,DWARF) + + returns values + + OUTCH - INTEGER + Standard output channel on the machine being used. + MCHEPS - DOUBLE PRECISION + The unit of roundoff, that is, the largest positive number + such that 1.0D0 + MCHEPS = 1.0D0. + DWARF - DOUBLE PRECISION + The smallest positive number on the machine being used. + + Some errors that can arise in the use of RKSUITE are catastrophic. Examples + include input arguments that are meaningless in context or are inconsistent, + and calls to subroutines that have not been initialized or cannot be used in + the context prevailing. A catastrophic error will automatically lead to an + explanatory message on the output channel OUTCH and the program STOPping. (It + is possible to override this STOP so that the main program can go on to + another task. This is done by means of the subroutines SOFTFL and CHKFL -- + see the descriptions of the subroutines for instructions.) + +******************************************************************************* +---------------------Description of Subroutine SETUP------------------------ + + + SUBROUTINE SETUP(NEQ,TSTART,YSTART,TEND,TOL,THRES,METHOD,TASK,ERRASS, + HSTART,WORK,LENWRK,MESAGE) + + SETUP initializes the computation, so it is normally called only once. A call + to SETUP must precede the first call to UT or CT. Any subsequent call to + SETUP reinitializes the computation. When calling SETUP, you must specify + the + + INPUT VARIABLES + + NEQ - INTEGER + The number of differential equations (the number of + solution components) in the system. + Constraint: NEQ >= 1 + TSTART - DOUBLE PRECISION + The initial value of the independent variable. + YSTART(*) - DOUBLE PRECISION array of length NEQ + The vector of initial values of the solution components. + TEND - DOUBLE PRECISION + The integration proceeds from TSTART in the direction + of TEND. You can, and often will, terminate the integration + before reaching TEND, but you cannot integrate past TEND. + Constraint: TEND must be clearly distinguishable from TSTART + in the precision available. + + The integration proceeds by steps from TSTART towards TEND. An approximate + solution Y(*) is computed at each step. For each component Y(L), L = 1,2, + ...,NEQ, the error made in the step, i.e. the local error, is estimated. + The step size is chosen automatically so that the integration will proceed + efficiently while keeping this local error estimate smaller than a tolerance + that you specify by means of parameters TOL and THRES(*). + + You should consider carefully how you want the local error to be controlled. + This code basically uses relative local error control, with TOL being the + desired relative accuracy. For reliable computation, codes must work with + approximate solutions that have some correct digits, so you are not allowed + to specify TOL greater than 0.01D0. It is impossible to compute a numerical + solution more accurate than the correctly rounded value of the true solution, + so you are not allowed to specify a TOL that is too small for the precision + you are using. Specifically, TOL must be greater than ten times the machine- + dependent parameter MCHEPS. + + The magnitude of the local error in Y(L) on any step will not be greater + than TOL*max("size(L)",THRES(L)) where "size(L)" is an average magnitude + of Y(L) over the step. If THRES(L) is smaller than the current value of + "size(L)", this is a relative error test and TOL indicates how many + significant digits you want in Y(L). If THRES(L) is larger than the + current value of "size(L)", this is an absolute error test with tolerance + TOL*THRES(L). Relative error control is the recommended mode of operation, + but pure relative error control, THRES(L) = 0.0D0, is not permitted. + Specifically, THRES(L) cannot be smaller than the machine-dependent + parameter SQRT(DWARF). It is often the case that a solution component Y(L) + is of no interest when it is smaller in magnitude than a certain threshold. + You can inform the code of this by setting THRES(L) to this threshold. In + this way you avoid the cost of computing significant digits in Y(L) when + only the fact that it is smaller than the threshold is of interest. This + matter is important when Y(L) vanishes, and in particular, when the initial + value YSTART(L) vanishes. An appropriate threshold depends on the general + size of Y(L) in the course of the integration. Physical reasoning may help + you select suitable threshold values. If you do not know what to expect of + Y(*), you can find out by a preliminary integration using UT with nominal + values of THRES(*). As UT steps from TSTART towards TEND, for each L = 1,2, + ...,NEQ it forms YMAX(L), the largest magnitude of Y(L) computed at any step + in the integration so far. Using it you can determine more appropriate values + for THRES(*) for an accurate integration. You might, for example, take + THRES(L) to be 10.0D0*MCHEPS times the final value of YMAX(L). + + TOL - DOUBLE PRECISION + The relative error tolerance. + Constraint: 0.01D0 >= TOL >= 10.D0*MCHEPS + THRES(*) - DOUBLE PRECISION array of length NEQ + For L = 1,2,...,NEQ, THRES(L) is a threshold for solution + component Y(L). Choose it so that the value of Y(L) is not + important when Y(L) is smaller in magnitude than THRES(L). + Constraint: THRES(L) >= SQRT(DWARF) + + Like practically all codes, UT and CT control local error rather than the + true (global) error, the difference between the numerical and true solution. + Control of the local error controls the true error indirectly. Roughly + speaking, the code produces a solution that satisfies the differential + equation with a discrepancy bounded in magnitude by the error tolerance. + What this implies about how close the numerical solution is to the true + solution depends on the stability of the problem. Most practical problems + are at least moderately stable, and the true error is then comparable to + the error tolerance. To judge the accuracy of the numerical solution, you + could reduce TOL substantially, e.g. use 0.1D0*TOL, and solve the problem + again. This will usually result in a rather more accurate solution, and + the true error of the first integration can be estimated by comparison. + Alternatively, a global error assessment can be computed automatically + by setting ERRASS (see below) to .TRUE.. Because indirect control of the + true error by controlling the local error is generally satisfactory and + because both ways of assessing true errors cost twice, or more, the cost + of the integration itself, such assessments are used mostly for spot checks, + selecting appropriate tolerances for local error control, and exploratory + computations. + + RKSUITE implements three Runge-Kutta formula pairs, and you must select + one for the integration. + + METHOD - INTEGER + Specify which Runge-Kutta pair is to be used. + = 1 - use the (2,3) pair + = 2 - use the (4,5) pair + = 3 - use the (7,8) pair + Constraint: 1 <= METHOD <= 3 + + The best choice for METHOD depends on the problem. The order of accuracy is + 3,5,8, respectively. As a rule, the smaller TOL is, the larger you should + take the value of METHOD. If the components THRES(L) are small enough that + you are effectively specifying relative error control, experience suggests + + TOL most efficient METHOD + -2 -4 + 10 -- 10 1 + -3 -6 + 10 -- 10 2 + -5 + 10 -- 3 + + The overlap in the ranges of tolerances appropriate for a given METHOD + merely reflects the dependence of efficiency on the problem being solved. + Making TOL smaller will normally make the integration more expensive. + However, in the range of tolerances appropriate to a METHOD, the increase + in cost is modest. There are situations for which one METHOD, or even this + kind of code, is a poor choice. You should not specify a very small + THRES(L), like SQRT(DWARF), when the Lth solution component might vanish. + In particular, you should not do this when YSTART(L) = 0.0D0. If you do, + the code will have to work hard with any METHOD to compute significant + digits, but METHOD = 1 is a particularly poor choice in this situation. All + three METHODs are inefficient when the problem is "stiff". If it is only + mildly stiff, you can solve it with acceptable efficiency with METHOD = 1, + but if it is moderately or very stiff, a code designed specifically for such + problems will be much more efficient. The higher the order, i.e. the larger + METHOD, the more smoothness is required of the solution for the METHOD to + be efficient. + + You must decide which integrator, UT or CT, to use. UT solves the "Usual + Task", namely integrating the system of differential equations to obtain + answers at points you specify. CT is used for all more "Complicated Task"s. + + TASK - CHARACTER*(*) + Only the first character of TASK is significant. + TASK(1:1) = `U' or `u' - UT is to be used + = `C' or `c' - CT is to be used + Constraint: TASK(1:1) = `U' or `u' or `C' or `c' + + An assessment of the true (global) error is provided by setting ERRASS = + .TRUE.. The error assessment is updated at each step. Its value can be + obtained at any time by a call to subroutine GLBERR. + + Warning: The code monitors the computation of the global error assessment + and reports any doubts it has about the reliability of the results. The + assessment scheme requires some smoothness of f(t,y), and it can be deceived + if f is insufficiently smooth. At very crude tolerances the numerical + solution can become so inaccurate that it is impossible to continue assessing + the accuracy reliably. At very stringent tolerances the effects of finite + precision arithmetic can make it impossible to assess the accuracy reliably. + In either case the code returns with a message and a flag (UFLAG = 6 in UT + and CFLAG = 6 in CT) reporting that global error assessment has broken down. + + ERRASS - LOGICAL + = .FALSE. - do not attempt to assess the true error. + = .TRUE. - assess the true error, the difference between + the numerical solution and the true solution. + (The cost of this is roughly twice the cost + of the integration itself with METHODs 2 and 3, + and three times with METHOD = 1.) + + The first step of the integration is critical because it sets the scale of + the problem. The integrator will find a starting step size automatically if + you set the variable HSTART to 0.0D0. Automatic selection of the first step + is so effective that you should normally use it. Nevertheless, you might + want to specify a trial value for the first step to be certain that the code + recognizes the scale on which phenomena occur near the initial point. Also, + automatic computation of the first step size involves some cost, so supplying + a good value for this step size will result in a less expensive start. If you + are confident that you have a good value, provide it in the variable HSTART. + + HSTART - DOUBLE PRECISION + 0.0D0 - The code will select automatically the first + step size (recommended choice). + non-zero - The code will try ABS(HSTART) for the first step + size of the integration. + + You must provide working memory for SETUP, UT, and CT in the array WORK(*). + Do not alter the contents of this array after calling SETUP. Just how much + memory is needed depends on which METHOD is used. LENWRK tells the code + how much memory you are providing. + + WORKSPACE + + WORK(*) - DOUBLE PRECISION array of length LENWRK + Do not alter the contents of this array after calling SETUP. + + INPUT VARIABLES + + LENWRK - INTEGER + Length of WORK(*): How big LENWRK must be depends + on the task and how it is to be solved. + + LENWRK = 32*NEQ is sufficient for all cases. + + If storage is a problem, the least storage possible + in the various cases is: + + If TASK = `U' or `u', then + if ERRASS = .FALSE. and + METHOD = 1, LENWRK must be at least 10*NEQ + = 2 20*NEQ + = 3 16*NEQ + if ERRASS = .TRUE. and + METHOD = 1, LENWRK must be at least 17*NEQ + = 2 32*NEQ + = 3 21*NEQ + + If TASK = `C' or `c', then + if ERRASS = .FALSE. and + METHOD = 1, LENWRK must be at least 10*NEQ + = 2 14*NEQ + = 3 16*NEQ + if ERRASS = .TRUE. and + METHOD = 1, LENWRK must be at least 15*NEQ + = 2 26*NEQ + = 3 21*NEQ + + Warning: To exploit the interpolation capability of METHODs 1 and 2, you + must call subroutine INTRP. This requires working storage in + addition to that specified in LENWRK. + + UT and CT communicate with your calling program by means of a parameter, + UFLAG and CFLAG respectively. If you wish, you can also have messages written + to the standard output channel OUTCH. The messages provide more detail, so it + is advisable to permit them for all but production runs. + + MESAGE - LOGICAL + Specify whether you want informative messages written to the + standard output channel OUTCH. + = .TRUE. - provide messages (recommended choice for + exploratory computations) + = .FALSE. - do not provide messages + + The data input to SETUP is monitored. Any error detected is catastrophic. An + error message is written to the output channel OUTCH (even if MESAGE = + .FALSE.), and the program STOPs. + +-------------------End of Description of Subroutine SETUP-------------------- + +************************ UT: Code for the Usual Task ************************** + + Code UT is a member of the suite, RKSUITE, for solving the initial value + problem for a first order system of ordinary differential equations by + Runge-Kutta methods. UT is designed for the "Usual Task", namely to compute + an approximate solution at a sequence of points. First you call SETUP to + specify the problem and how it is to be solved. Thereafter you (repeatedly) + call UT to obtain answers at points you specify. Another code, CT, in + RKSUITE is provided for all more "Complicated Task"s. + + UT requires you to specify a sequence of output points. They must be clearly + distinguishable in the precision available, and they must be distinguishable + from t and t as defined in the previous call to SETUP. You are + start end + extremely unlikely to specify points that are not clearly distinguishable + except by mistake. Should this happen, the code will tell you how far apart + the points must be. + +----------------------Description of Subroutine UT-------------------------- + + SUBROUTINE UT(F,TWANT,TGOT,YGOT,YPGOT,YMAX,WORK,UFLAG) + + A call to SETUP must precede the first call to UT. The results of this + call initializing the computation and the results of the previous call (if + any) to UT are retained in the array WORK(*), so the contents of this array + must not be altered between calls to UT. + + The system of NEQ first order differential equations is defined by a + subroutine F(T,Y,YP) that you must provide. You may give this subroutine + any name you like, but you must declare the name in an EXTERNAL statement in + the program that calls UT. This subroutine must have the form: + + SUBROUTINE F(T,Y,YP) + ...Scalar arguments and other scalar variables... + DOUBLE PRECISION T + ...Array arguments and other array variables... + DOUBLE PRECISION Y(*),YP(*) + Given input values of the independent variable T and the solution + components Y(*), for each L = 1,2,...,NEQ, evaluate the differential + equation for the derivative of the Lth solution component and place the + value in YP(L). Do not alter the input values of T and Y(*). + RETURN + END + + NAME DECLARED IN AN EXTERNAL STATEMENT IN THE PROGRAM CALLING UT: + + F - name of the subroutine for evaluating the differential + equations + + UT attempts to approximate the true solution of the initial value problem + and its first derivative at the point TWANT specified in the call to UT. + On return, the code has integrated successfully to TGOT, and YGOT(*) and + YPGOT(*) are accurate approximations to the solution and its first + derivative at TGOT. If all has gone well, (the machine number) TGOT equals + (the machine number) TWANT and UFLAG = 1. If the code did not reach TWANT + (TGOT is not equal to TWANT), an explanation is indicated by the value + of UFLAG. The integration proceeds by steps from TSTART towards TEND (both + specified in SETUP). For this reason, the specified TWANT must be closer to + TEND than the previous value of TGOT (TSTART on the first call to UT). + TWANT can equal TEND. As UT steps from TSTART towards TEND, for each + L = 1,2,...,NEQ it forms YMAX(L), the largest magnitude of Y(L) computed at + any step in the integration so far. + + INPUT VARIABLE + + TWANT - DOUBLE PRECISION + The next value of the independent variable where a solution + is desired. + Constraint: TWANT must be closer to TEND than the previous + value of TGOT (TSTART on the first call to UT). It can be + equal to TEND. Unless exactly equal to TEND, it must be + clearly distinguishable from TEND and from TGOT, in the + precision available. + + OUTPUT VARIABLES: Do not alter any of these variables between calls to UT + + TGOT - DOUBLE PRECISION + A solution has been computed at this value of the independent + variable. If the task was completed successfully, this + machine number is the same as the machine number TWANT. If + the code did not reach TWANT, an explanation is provided by + the value of UFLAG. + YGOT(*) - DOUBLE PRECISION array of length NEQ + Approximation to the true solution at TGOT. At each step of + the integration to TGOT, the local error has been controlled + as specified by TOL and THRES(*) in SETUP. The local error + in the reported values YGOT(*) has been controlled even when + TGOT differs from TWANT. + YPGOT(*) - DOUBLE PRECISION array of length NEQ + Approximation to the first derivative of the true solution at + TGOT. The local error has been controlled even when TGOT + differs from TWANT. + YMAX(*) - DOUBLE PRECISION array of length NEQ + YMAX(L) is the largest value of ABS(Y(L)) computed at + any step in the integration so far. (With METHODs 1 and 2, + YGOT(L) is computed by interpolation, so YMAX(L) might be + a little larger in magnitude than any value ABS(YGOT(L)) + reported so far.) + + WORKSPACE + + WORK(*) - DOUBLE PRECISION array specified in the subroutine SETUP. + Do not alter the contents of this array. + + UT reports success by setting UFLAG = 1. Difficulties with the integration + are reported by values UFLAG > 1. If MESAGE was set .TRUE. in the call to + SETUP, details about the difficulties are written to the standard output + channel OUTCH. If UT fails catastrophically, for example if values of its + input variables are incompatible with those provided in SETUP, details are + written to the output channel OUTCH (even if MESAGE was set .FALSE.), and + the program STOPs. + + OUTPUT VARIABLE + + UFLAG - INTEGER + SUCCESS. TGOT = TWANT. + = 1 - Successful call. To compute an approximation at a new + TWANT, just call UT again with the new value of TWANT. + Do not alter any other variable. + + "SOFT FAILURES" + = 2 - This return is possible only when METHOD = 3. The code + is being used inefficiently because the step size has + been reduced drastically many times to get answers at + many points TWANT. If you really need the solution + at this many points, you should change to METHOD = 2 + because it is (much) more efficient in this situation. + To change METHOD, restart the integration from TGOT, + YGOT(*) by a call to SETUP. If you wish to continue + with METHOD = 3, just call UT again. Do not alter any + variable. The monitor of this kind of inefficiency + will be reset automatically so that the integration + can proceed. + = 3 - A considerable amount of work has been expended in the + (primary) integration. This is measured by counting the + number of calls to the subroutine F. At least 5000 + calls have been made since the last time this counter + was reset. Calls to F in a secondary integration for + global error assessment (when ERRASS is set to .TRUE. + in the initialization call to SETUP) are not counted + in this total. The integration was interrupted, so TGOT + is not equal to TWANT. If you wish to continue on + towards TWANT, just call UT again. Do not alter any + variable. The counter measuring work will be reset to + zero automatically. + = 4 - It appears that this problem is "stiff". The methods + implemented in UT can solve such problems, but they are + inefficient. You should change to another code based + on methods appropriate for stiff problems. If you want + to continue on towards TWANT, just call UT again. Do + not alter any variable. The stiffness monitor will be + reset automatically. + + "HARD FAILURES" + = 5 - It does not appear possible to achieve the accuracy + specified by TOL and THRES(*) in the call to SETUP with + the precision available on this computer and with this + value of METHOD. You cannot continue integrating this + problem. A larger value for METHOD, if possible, will + permit greater accuracy with this precision. To increase + METHOD and/or continue with larger values of TOL and/or + THRES(*), restart the integration from TGOT, YGOT(*) by a + call to SETUP. + = 6 - The global error assessment may not be reliable beyond + the current integration point TGOT. This may occur + because either too little or too much accuracy has been + requested or because f(t,y) is not smooth enough for + values of t just past TGOT and current values of the + solution y. The integration cannot be continued. This + return does not mean that you cannot integrate past TGOT, + rather that you cannot do it with ERRASS = .TRUE.. + However, it may also indicate problems with the primary + integration. + + Performance statistics are available after any return from UT by a call to + the subroutine STAT. IF ERRASS was set .TRUE. in the call to SETUP, global + error assessment is available after any return from UT by a call to the + subroutine GLBERR. + + After a hard failure (UFLAG = 5 or 6) the diagnostic subroutines STAT and + GLBERR may be called only once. Other subroutines from RKSUITE may not + be called at all, except SETUP to restart the integration. + +-----------------End of Description of Subroutine UT------------------------ + +------------------Description of Subroutine GLBERR-------------------------- + + SUBROUTINE GLBERR(RMSERR,ERRMAX,TERRMX,WORK) + + To assess the true (global) error of the integration with CT or UT, set + ERRASS = .TRUE. in the call to SETUP. After any call to CT or UT, GLBERR + may be called for information about the assessment. The solution Y(*) is + computed in the primary integration. (The values YGOT(*) in UT and YNOW(*) + in CT result from the primary integration.) A more accurate "true" solution + YT(L) is computed in a secondary integration. The error is measured as + specified in SETUP for local error control. At each step in the primary + integration, an average magnitude "size(L)" of component Y(L) is computed, and + the error in the component is + + abs(Y(L) - YT(L))/max("size(L)",THRES(L)). + + It is difficult to estimate reliably the true error at a single point. For + this reason the RMS (root-mean-square) average of the estimated global error + in the Lth solution component is returned in RMSERR(L). This average is taken + over all steps from TSTART through the current integration point. If all has + gone well, the average errors reported in RMSERR(*) will be comparable to + TOL. Other useful quantities are ERRMAX, the maximum error seen in any + component in the integration so far, and TERRMX, the point where the maximum + error first occurred. + + You may call GLBERR only once after a hard failure in UT or CT. + + OUTPUT VARIABLES + + RMSERR(*) - DOUBLE PRECISION array of length NEQ + RMSERR(L) approximates the RMS average of the true error of + the numerical solution for the Lth solution component, + L = 1,2,...,NEQ. The average is taken over all steps from + TSTART through the current integration point. If all has + gone well, each component RMSERR(L) will be comparable to TOL. + ERRMAX - DOUBLE PRECISION + The maximum weighted approximate true error taken over all + solution components and all steps from TSTART through the + current integration point. If all has gone well, ERRMAX + will be comparable to TOL. + TERRMX - DOUBLE PRECISION + First value of the independent variable where an approximate + true error attains the maximum value ERRMAX. + + WORKSPACE + + WORK(*) - DOUBLE PRECISION array specified in the subroutine SETUP. + Do not alter the contents of this array. + + The call to GLBERR is monitored. Any error is catastrophic. An error + message is written to the output channel OUTCH (even if MESAGE = .FALSE.), + and the program STOPs. + +-----------------End of Description of Subroutine GLBERR--------------------- + +---------------------Description of Subroutine STAT-------------------------- + + SUBROUTINE STAT(TOTF,STPCST,WASTE,STPSOK,HNEXT) + + STAT may be called after any call to UT or CT to obtain details about the + integration. + + You may call STAT only once after a hard failure in UT or CT. + + + OUTPUT VARIABLES + + TOTF - INTEGER + Total number of calls to F in the integration so far -- + a measure of the cost of the integration. + STPCST - INTEGER + Cost of a typical step with this METHOD measured in + calls to F. + WASTE - DOUBLE PRECISION + The number of attempted steps that failed to meet the local + error requirement divided by the total number of steps + attempted so far in the integration. A "large" fraction + indicates that the integrator is having trouble with this + problem. This can happen when the problem is "stiff" and + also when the solution y(t) has discontinuities in a low + order derivative. + STPSOK - INTEGER + The number of accepted steps. + HNEXT - DOUBLE PRECISION + The step size the integrator plans to use for the next step. + + The call to STAT is monitored. Any error is catastrophic. An error + message is written to the output channel OUTCH (even if MESAGE = .FALSE.), + and the program STOPs. + +-----------------End of Description of Subroutine STAT----------------------- + +************************ CT: Codes for Complicated Tasks ********************** + + CT is a member of a suite of codes, RKSUITE, for solving the initial value + problem for a first order system of ordinary differential equations by + Runge-Kutta methods. SETUP is used to specify the problem and how it is to + be solved. CT is used to advance the integration one step. Another code, + UT, in RKSUITE is provided for the "Usual Task" of obtaining an approximate + solution at a sequence of points. The code CT is designed for the solution + of more "Complicated Task"s that require close monitoring of the integration + and additional capabilities. To make this code easier to use, less common + demands are handled by means of the auxiliary subroutines INTRP and RESET. + +----------------------------------------------------------------------------- +---------------------Description of Subroutine CT--------------------------- + + SUBROUTINE CT(F,TNOW,YNOW,YPNOW,WORK,CFLAG) + + + A call to SETUP must precede the first call to CT. The results of this call + initializing the computation and the results of the previous call (if any) + to CT are retained in the array WORK(*), so the contents of this array must + not be altered between calls to CT. + + CT is used to step from TSTART in the direction of TEND as specified in SETUP. + One way to use CT involves repeatedly resetting TEND, so a subroutine RESET + is provided for this purpose. When CT is called, YNOW(*) approximates the + solution at TNOW and YPNOW(*) approximates the first derivative there. These + quantities come from the preceding call to CT (SETUP on the first call). If + the code encounters some difficulty in taking a step, it returns with these + values unaltered and provides an explanation by means of the value of CFLAG. + If all goes well, CT returns with CFLAG = 1, and YNOW(*) and YPNOW(*) are the + new values of the approximate solution at the end of a single step to the new + TNOW. CT tries to advance the integration as far as possible subject to + passing the test on the local error and not going past TEND. In the call to + SETUP, you specify that CT try HSTART as its first step size or that it + compute automatically an appropriate value. Thereafter CT estimates an + appropriate step size for its next step. This value and other details of the + integration can be obtained after any call to CT by a call to the subroutine + STAT in RKSUITE. The local error is controlled at every step as specified in + SETUP. If you wish to assess the true error, you must set ERRASS = .TRUE. in + the call to SETUP. This assessment can be obtained after any call to CT by a + call to the subroutine GLBERR. + + There are three ways to use CT: + + 1. Step from TSTART towards TEND, accepting answers at the points chosen by + the code. This is often the best way to proceed when you want to see how + the solution behaves throughout the interval of integration because the + code will tend to produce answers more frequently where the solution + changes more rapidly (the step sizes tend to be smaller there). + +** If you want answers at specific points, two ways to proceed are: + + 2. The more efficient way is to step past the point where a solution is + desired, and then call a subroutine, INTRP, in RKSUITE to get an answer + there. Within the span of the current step, you can get all the answers + you want at very little cost by repeated calls to INTRP. This is very + valuable when you want to find where something happens, e.g., where a + particular solution component vanishes. You cannot proceed in this + way with METHOD = 3. + + 3. The other way to get an answer at a specific point is to set TEND to + this value and integrate to TEND. CT will not step past TEND, so when a + step would carry it past, it will reduce the step size so as to produce + an answer at TEND exactly. After getting an answer there (TNOW = TEND), + you can reset TEND to the next point where you want an answer, and + repeat. TEND could be reset by a call to SETUP, but you should not do + this. You should use the subroutine RESET because it is both easier to + use and much more efficient. This way of getting answers at specific + points can be used with any of the METHODs, but it is the only way with + METHOD = 3. It can be inefficient. Should this be the case, the code + will bring the matter to your attention. + + The system of NEQ first order differential equations is defined by a + subroutine F(T,Y,YP) that you must provide. You may give this subroutine any + name you like, but you must declare the name in an EXTERNAL statement in the + program that calls CT. This subroutine must have the form + + SUBROUTINE F(T,Y,YP) + ...Scalar arguments and other scalar variables... + DOUBLE PRECISION T + ...Array arguments and other array variables... + DOUBLE PRECISION Y(*),YP(*) + Given input values of the independent variable T and the solution + components Y(*), for each L = 1,2,...,NEQ evaluate the differential + equation for the derivative of the Lth solution component and place the + value in YP(L). Do not alter the input values of T and Y(*). + RETURN + END + + NAME DECLARED IN AN EXTERNAL STATEMENT IN THE PROGRAM CALLING CT: + + F - name of the subroutine for evaluating the differential + equations + + On each call, CT tries to take a step from the current value of TNOW + (initially TSTART) in the direction of TEND. On the previous call, the code + estimated an appropriate step size. (On the first call, either you provide + the step size, or one is determined automatically.) If this step size is too + big for the formula to achieve the specified accuracy, the code will adjust + the step size and try again. It keeps trying until it produces a solution + that is sufficiently accurate, or it decides to report that it has run into + trouble via CFLAG (and the standard output channel OUTCH if MESAGE was set + .TRUE. in SETUP). In any case, the values returned in YNOW(*) and YPNOW(*) + satisfy the specified accuracy requirement at the value TNOW returned. + + OUTPUT VARIABLES + + TNOW - DOUBLE PRECISION + Current value of the independent variable after a step + towards TEND. + YNOW(*) - DOUBLE PRECISION array of length NEQ + Approximation to the solution at TNOW. The local error + of the step to TNOW was no greater than permitted by the + tolerances TOL, THRES(*) as specified in SETUP. + YPNOW(*) - DOUBLE PRECISION array of length NEQ + Approximation to the derivative of the solution at TNOW. + + WORKSPACE + + WORK(*) - DOUBLE PRECISION array specified in the subroutine SETUP. + Do not alter the contents of this array. + + CT reports success by setting CFLAG = 1. Difficulties with the integration + are reported by values of CFLAG > 1. In such cases the integration has not + advanced and TNOW, YNOW(*), and YPNOW(*) are unchanged. If MESAGE was set + .TRUE. in the call to SETUP, some details about the difficulty are written + to the standard output channel OUTCH. The call to CT is monitored. If a + catastrophic error is detected, for example when CT has been called out of + context, then an error message is written to the output channel OUTCH (even + if MESAGE was set to .FALSE.), and the program STOPs. + + Performance statistics are available after any return from CT by a call to + the subroutine STAT. IF ERRASS was set .TRUE. in the call to SETUP, global + error assessment is available after any return from CT by a call to the + subroutine GLBERR. + + After a hard failure (CFLAG = 5 or 6) the diagnostic subroutines STAT and + GLBERR may be called only once. Other subroutines from RKSUITE may not + be called at all, except SETUP to restart the integration. + + CFLAG - INTEGER + "SUCCESS" + = 1 - Successful call. A step was taken to TNOW. To + continue the integration in the direction of TEND, + just call CT again. Do not alter any variables. + + "SOFT FAILURE" + = 2 - The code is being used inefficiently because the step + size has been reduced drastically many times to get + answers at many values of TEND. If you really need the + solution at this many specific points, you should + use INTRP to get the answers inexpensively. If you + need to change METHOD for this purpose, restart the + integration from TNOW, YNOW(*) by a call to SETUP. If + you wish to continue as before, just call CT again. Do + not alter any variable. The monitor of this kind of + inefficiency will be reset automatically so that the + integration can proceed. + = 3 - A considerable amount of work has been expended in the + (primary) integration. This is measured by counting the + number of calls to the subroutine F. At least 5000 calls + have been made since the last time this counter was + reset. Calls to F in a secondary integration for global + error assessment (when ERRASS is set to .TRUE. in the + initialization call to SETUP) are not counted in this + total. If you wish to continue on towards TEND, just + call CT again. Do not alter any variable. The counter + measuring work will be reset to zero automatically. + = 4 - It appears that this problem is "stiff". The methods + implemented in CT can solve such problems, but they + are inefficient. You should change to another code + based on methods appropriate for stiff problems. If + you want to continue, just call CT again. Do not alter + any variable. The stiffness monitor will be reset + automatically. + + "HARD FAILURE" + = 5 - It does not appear possible to achieve the accuracy + specified by TOL and THRES(*) in the call to SETUP with + the precision available on this computer and with this + value of METHOD. You cannot continue integrating this + problem. A larger value for METHOD, if possible, will + permit greater accuracy with this precision. To increase + METHOD and/or continue with larger values of TOL and/or + THRES(*), restart the integration from TNOW, YNOW(*) by a + call to SETUP. + = 6 - The global error assessment may not be reliable beyond + the current integration point TNOW. This may occur + because either too little or too much accuracy has been + requested or because f(t,y) is not smooth enough for + values of t just past TNOW and current values of the + solution y. The integration cannot be continued. This + return does not mean that you cannot integrate past TNOW, + rather that you cannot do it with ERRASS = .TRUE.. + However, it may also indicate problems with the primary + integration. + + Statistics of the performance of CT are available after any return from CT + by a call to the subroutine STAT. IF ERRASS was set .TRUE. in the call to + SETUP, global error assessment is available after any return from CT by a + call to the subroutine GLBERR. + + After a hard failure (CFLAG = 5 or 6) the diagnostic subroutines STAT and + GLBERR may be called only once. Other subroutines from RKSUITE may not + be called at all, except SETUP to restart the integration. + +-----------------End of Description of Subroutine CT------------------------- + +--------------------Description of Subroutine RESET-------------------------- + + SUBROUTINE RESET(TENDNU) + + In the description of CT it is explained how to get answers at specific values + of the independent variable by resetting TEND. SETUP could be used to reset + TEND, but there are good reasons for calling RESET for this specific task: + + * RESET is simpler to use. + + * RESET is much more efficient than SETUP because it only resets the + value of a variable whereas SETUP completely restarts the integration. + + The integration proceeds from TSTART in the direction of TEND, and at + present is at TNOW. To change TEND to a new value TENDNU, just call RESET + with TENDNU as the argument. You must continue integrating in the same + direction, so the sign of (TENDNU - TNOW) must be the same as the sign of + (TEND - TSTART). To change direction of integration you must restart by a + call to SETUP. RESET cannot be called after a call to UT. + + INPUT VARIABLE + + TENDNU - DOUBLE PRECISION + The new value of TEND. + Constraints: sign(TENDNU - TNOW) = sign(TEND - TSTART). + TEND must be clearly distinguishable from TNOW in the + precision available. + + The call to RESET is monitored. Any error is catastrophic. An error + message is written to the output channel OUTCH (even if MESAGE = .FALSE.), + and the program STOPs. + +-----------------End of Description of Subroutine RESET---------------------- + +---------------------Description of Subroutine INTRP------------------------- + + SUBROUTINE INTRP(TWANT,REQEST,NWANT,YWANT,YPWANT,F,WORK,WRKINT,LENINT) + + In the description of CT it is explained that when integrating with METHOD = + 1 or 2, answers can be obtained inexpensively by interpolation. Subroutine + INTRP is provided for this purpose. Within the span of each step the solution + is approximated by a polynomial of degree MINT = 3 when METHOD = 1 and a + polynomial of degree MINT = 6 when METHOD = 2. The polynomials can be + evaluated anywhere, but the theory assures accurate approximations for the + solution and its first derivative only within the span of the current step, or + very close to it. The interpolants for successive steps connect to form a + piecewise-polynomial approximation over the whole interval of integration that + is continuous and has a continuous derivative (in the precision available). + + With METHOD = 1, the interpolant uses just solution and derivative + information returned after calls to CT. The matter is more complicated and + expensive with METHOD = 2. In the latter case additional calls to the + derivative evaluation subroutine F are needed to initialize the computation. + Although more expensive than for METHOD = 1, this extra cost is incurred + only on those steps where you require interpolation, and then only once per + step, no matter how many answers you require in the span of the step. In + either case it is far more efficient to let the code work with the largest + step size that will yield the desired accuracy and obtain answers by + interpolation than to obtain answers by reducing the step size so as to + step to the points where the answers are desired. + + INTRP is called after a successful step by CT from a previous value of TNOW, + called TOLD below, to the current value of TNOW to get an answer at TWANT. + You can specify any value of TWANT you wish, but specifying a value outside + the interval [TOLD,TNOW], called "extrapolation," is likely to yield answers + with unsatisfactory accuracy. + + Warning: You cannot call INTRP after a return from CT with any kind of + failure. You cannot call INTRP when you are using UT. + + INPUT VARIABLE + + TWANT - DOUBLE PRECISION + The value of the independent variable where a solution + is desired. + + The interpolant is to be evaluated at TWANT to approximate the solution + and/or its first derivative there. There are three cases: + + REQEST - CHARACTER*(*) + Only the first character of REQEST is significant. + REQEST(1:1) = `S' or `s'- compute approximate `S'olution only. + = `D' or `d'- compute approximate first + `D'erivative of the solution only. + = `B' or `b'- compute `B'oth approximate solution + and first derivative. + Constraint: REQEST(1:1) must be `S',`s',`D',`d',`B' or `b'. + + Often you will not want all the components of the solution and/or its + derivative. INTRP approximates only the first NWANT components. By arranging + that the components interesting to you are among the first NWANT components, + you can reduce the overhead. If you intend to interpolate only a few + components but at many points, this capability can be worth your while. + + NWANT - INTEGER + The first NWANT components of the answer are to be computed. + Constraint: NEQ >= NWANT >= 1 + + OUTPUT VARIABLES + + YWANT(*) - DOUBLE PRECISION array of length NWANT + Approximation to the first NWANT components of the true + solution at TWANT when REQuESTed. YWANT(*) is not defined + when the solution is not REQuESTed. + YPWANT(*) - DOUBLE PRECISION array of length NWANT + Approximation to the first NWANT components of the first + derivative of the true solution at TWANT when REQuESTed. + YPWANT(*) is not defined when the derivative of the solution + is not REQuESTed. + + Because INTRP may need to evaluate the differential equations, it must be + supplied with the name of the subroutine you provided to CT for evaluating + the differential equations. + + NAME DECLARED IN AN EXTERNAL STATEMENT IN THE PROGRAM CALLING INTRP: + + F - name of the subroutine for evaluating the differential + equations provided to CT. + + INTRP requires information about the last step from CT. This is + communicated by means of the workspace. + + WORKSPACE + + WORK(*) - DOUBLE PRECISION array specified in the subroutine SETUP. + Do not alter the contents of this array. + + A small amount of additional workspace is required for interpolation. + + WRKINT(*) - DOUBLE PRECISION array of length LENINT + Do not alter the contents of this array. + + INPUT VARIABLE + + LENINT - INTEGER + Length of WRKINT. If + METHOD = 1, LENINT must be at least 1 + = 2, LENINT must be at least NEQ+MAX(NEQ,5*NWANT) + = 3--CANNOT USE THIS SUBROUTINE + + The call to INTRP and the data input are monitored. Any error is + catastrophic. An error message is written to the output channel OUTCH + (even if MESAGE = .FALSE.), and the program STOPs. + +----------------End of Description of Subroutine INTRP---------------------- + +----------------End of RKSUITE Subroutine Documentation--------------------- + +-----------------------------ACKNOWLEDGEMENTS------------------------------- + + P.J. Prince and J.R. Dormand of Teesside Polytechnic developed one of + the pairs of Runge-Kutta formulas used in RKSUITE and P. Bogacki of Old + Dominion University and one of the authors developed the others. We + are grateful for the assistance these friends and colleagues gave us in + implementing their formulas. We also wish to thank G. Kraut of Southern + Methodist University for her meticulous testing of the codes and valuable + comments about the user interface. + + NATO Scientific Affairs Division (Grant 898/83) funded early joint work + of I. Gladwell and L.F. Shampine that led to the development of RKSUITE. + R.W. Brankin's involvement was entirely funded by the Numerical Algorithms + Group Ltd. Some of L.F. Shampine's research on basic algorithms used later + in RKSUITE was supported in part by the Applied Mathematical Sciences + program of the Office of Energy Research of the U.S. Department of Energy. + +--------------------------------REFERENCES----------------------------------- + + Some of the references that follow describe the formulas and algorithms + used in RKSUITE. Others describe the design, implementation, and testing + of codes based on explicit Runge-Kutta formulas and the development of + additional capabilities that played a more-or-less direct role in the + development of RKSUITE. + + C.A. Addison, W.H. Enright, P.W. Gaffney, I. Gladwell, and P.M. Hanson, + "A Decision Tree for the Numerical Solution of Initial Value Ordinary + Differential Equations", ACM Trans. on Math. Soft., 16 (1991), to appear. + + P. Bogacki and L.F. Shampine, "A 3(2) Pair of Runge-Kutta Formulas", Appl. + Math. Lett., 2 (1989) 321-325. + + P. Bogacki and L.F. Shampine, "An Efficient Runge-Kutta (4,5) Pair", Rept. + 89-20, Math. Dept., Southern Methodist University, Dallas, Texas, USA, 1989. + + R.W. Brankin, J.R. Dormand, I. Gladwell, P.J. Prince, and W.L. Seward, + "A Runge-Kutta-Nystrom Code", ACM Trans. on Math. Soft., 15 (1989) 31-40. + + R.W. Brankin, I. Gladwell, and L.F. Shampine, RKSUITE: a Suite of + Runge-Kutta Codes for the Initial Value Problem for ODEs, Softreport 91-1, + Math. Dept., Southern Methodist University, Dallas, Texas, U.S.A, 1991. + + R.W. Brankin and I. Gladwell, "Using Shape Preserving Local Interpolants + for Plotting Solutions of Ordinary Differential Equations", IMA J. of + Numer. Anal., 9 (1989) 555-566. + + R.W. Brankin, I. Gladwell, and L.F. Shampine, "Starting Adams and BDF + Codes at Optimal Order", J. Comp. Appl. Math., 21 (1988) 357-368. + + I. Gladwell, "Initial Value Routines in the NAG Library", ACM Trans. on + Math. Soft., 5 (1979) 386-400. + + I. Gladwell, J.A.I. Craigie, and C.R. Crowther, "Testing Initial Value + Routines as Black Boxes", Numer. Anal. Rept. 34, Math. Dept., Univ. of + Manchester, U.K., 1979. + + I. Gladwell, M. Berzins, and M. Brankin, "Design of Stiff Integrators + in the NAG Library, SIGNUM Newsletter, 23 (1988) 16-23. + + I. Gladwell, L.F. Shampine, L.S. Baca and R.W. Brankin, "Practical Aspects + of Interpolation with Runge-Kutta Codes", SIAM J. Sci., Stat. Comp., 8 + (1987) 322-341. + + I. Gladwell, L.F. Shampine and R.W. Brankin,"Automatic Selection of the + Initial Step Size for an ODE Solver", J. Comp. Appl. Math., 18 (1987) + 175-192. + + I. Gladwell, L.F. Shampine and R.W. Brankin, "Locating Special Events When + Solving ODEs", Appl. Math. Lett., 1 (1988) 153-156. + + G. Kraut, "A Comparison of RKSUITE with Runge-Kutta Codes from the IMSL, NAG + and SLATEC Libraries", Report 91-6, Math. Dept., Southern Methodist + University, Dallas, Texas, U.S.A., 1991. + + P.J. Prince and J.R. Dormand, " High Order Embedded Runge-Kutta Formulae", + J. Comput. Appl. Math., 7 (1981), 67-85. + + L.F. Shampine, "Local Extrapolation in the Solution of Ordinary + Differential Equations", Math. Comp., 27 (1973) 91-97. + + L.F. Shampine, "Limiting Precision in Differential Equation Solvers", Math. + Comp., 28 (1974) 141-144. + + L.F. Shampine, "Storage Reduction for Runge-Kutta Codes", ACM Trans. on + Math. Soft., 5 (1979) 245-250. + + L.F. Shampine, "Stiffness and Non-Stiff Differential Equation Solvers II: + Detecting Stiffness with Runge-Kutta Methods", ACM Trans. on Math. Soft., + 3 (1977) 44-53. + + L.F. Shampine, "Local Error Control in Codes for Ordinary Differential + Equations", Appl. Math. Comp., 3 (1977) 189-210. + + L.F. Shampine, "Limiting Precision in Differential Equation Solvers II: + Sources of Trouble and Starting a Code", Math. Comp., 32 (1978) 1115-1122. + + L.F. Shampine, "Lipschitz Constants and Robust ODE Codes", pp. 427-449 in + J.T. Oden, ed., Computational Methods in Nonlinear Mechanics, + North-Holland, Amsterdam, 1980. + + L.F. Shampine, "Estimating the Cost of Output in ODE Codes", Matematica + Aplicada e Computacional, 2 (1983) 157-169. + + L.F. Shampine, "Stiffness and the Automatic Selection of ODE Code", J. + Comp. Phys., 54 (1984) 74-86. + + L.F. Shampine, "Stability of Explicit Runge-Kutta Methods", Comp. & Maths. + with Applics., 10 (1984) 419-432. + + L.F. Shampine, "Measuring Stiffness", Appl. Numer. Math., 1 (1985) 107-119. + + L.F. Shampine, "The Step Sizes Used by One-Step Codes for ODEs", Appl. + Numer. Math., 1 (1985) 95-106. + + L.F. Shampine, "Interpolation for Runge-Kutta Methods", SIAM J. Numer. + Anal., 22 (1985) 1014-1027. + + L.F. Shampine, "Global Error Estimation with One-Step Methods", Comp. & + Maths. with Applics., 12A (1986) 885-894. + + L.F. Shampine, "Some Practical Runge-Kutta Formulas", Math. Comp., 46 + (1986) 135-150. + + L.F. Shampine, "Interpolation for Variable Order Runge-Kutta Methods", + Comp. & Maths. with Applics., 14 (1987) 255-260. + + L.F. Shampine, "Tolerance Proportionality in ODE Codes", pp. 118-136 in + Numerical Methods in ODEs, A. Bellen et al., eds.,Lecture Notes in Math. + #1386, Springer, Berlin, 1989. + + L.F. Shampine, "Diagnosing Stiffness for Runge-Kutta Methods", SIAM J. + Sci., Stat. Comput., 12 (1991) 260-272. + + L.F. Shampine and L.S. Baca, "Fixed vs. Variable Order Runge-Kutta", ACM + Trans. on Math. Soft., 12 (1986) 1-23. + + L.F. Shampine, S.M. Davenport, and H.A. Watts, " Comparison of Some Codes + for the Initial Value Problem for Ordinary Differential Equations", pp. + 349-353 in Numerical Solutions of Boundary Value Problems for Ordinary + Differential Equations, A. K. Aziz, ed., Academic, New York,1975. + + L.F. Shampine, S.M. Davenport, and H.A. Watts, "Solving Nonstiff Ordinary + Differential Equations -- the State of the Art", SIAM Review, 18 (1976) + 376-411. + + L.F. Shampine and I. Gladwell, "The Next Generation of Runge-Kutta + Codes", in Computational ODEs, J.R.Cash and I.Gladwell, eds., Oxford + University Press, 1991, to appear. + + L.F. Shampine, I. Gladwell, and R.W. Brankin, "Reliable Solution of Special + Root Finding Problems for ODE's", ACM Trans. on Math. Soft., 17 (1991) + 11-25. + + L.F. Shampine and M.K. Gordon, "Numerical Solution of Ordinary Differential + Equations: the Initial Value Problem", W. H. Freeman and Co., San + Francisco, 1975. + + L.F. Shampine, M.K. Gordon and J.A. Wisniewski, "Variable order + Runge-Kutta codes", pp. 83-101 in Computational Techniques for Ordinary + Differential Equations, I. Gladwell and D.K. Sayers, eds., Academic, + London, 1980. + + L.F. Shampine and H.A. Watts, "Comparing Error Estimators for Runge-Kutta + methods", Math. Comp., 25 (1971) 445-455. + + L.F. Shampine and H.A. Watts, "Global Error Estimation for Ordinary + Differential Equations", ACM Trans. on Math. Soft., 2 (1976) 172-186. + + L.F. Shampine and H.A. Watts, "The Art of Writing a Runge-Kutta Code, + Part I", in Mathematical Software III, J. R. Rice, ed., Academic, + New York, 1977. + + L.F. Shampine and H.A. Watts, "The Art of Writing a Runge-Kutta Code, II", + Appl. Math. Comp., 5 (1979) 93-121. + + H.A. Watts, "Step Size Control in Ordinary Differential Equation Solvers", + Trans. Soc. for Computer Simulation, 1 (1984), 15-25. + +************************** Installation Details ******************************* + + All machine-dependent aspects of the suite have been isolated in the + subroutine ENVIRN in the rksuite.for file. Certain environmental parameters + must be specified in this subroutine. The values in the distribution version + are those appropriate to the IEEE arithmetic standard. They must be altered, + if necessary, to values appropriate to the computing system you are using + before calling the codes of the suite. If the IEEE arithmetic standard values + are not appropriate for your system, appropriate values can often be obtained + by calling routines named in the Comments of ENVIRN. + + ================================================================ + ================================================================ + TO MAKE SURE THAT YOU SPECIFY THESE MACHINE AND INSTALLATION + DEPENDENT QUANTITIES PROPERLY, WHEN THE DISTRIBUTION VERSION IS + CALLED IT WRITES A MESSAGE ABOUT THE QUANTITIES TO THE STANDARD + OUTPUT CHANNEL THEN TERMINATES THE RUN. THE VALUES PROVIDED IN + THE DISTRIBUTION VERSION SHOULD BE ALTERED, IF NECESSARY, THEN + THE "WRITE" AND "STOP" STATEMENTS MUST BE COMMENTED OUT. + ================================================================ + ================================================================ + + The values of the coefficients of the Runge-Kutta methods are supplied in + the subroutine CONST as DOUBLE PRECISION constants. Some of the coefficients + are given to 30 significant figures. It is likely that your compiler will + round these constants correctly to the nearest representable machine number. + If possible, you should request your compiler to round the constants rather + than truncate them. Your compiler might warn you that it has shortened + the representation of the constants. The warning does not imply anything is + wrong, but you might wish to take action to avoid receiving such messages + every time you compile RKSUITE. + +************************** Organization Details ******************************* + + The file details.doc shows how the codes are organized. Included are: + (1) The ordering of the subroutines in the file rksuite.for. + (2) For each subroutine, there is a brief description, a list of + subroutines it calls,and a list of subroutines that call it directly. + (3) A description of the COMMON blocks used for communication throughout + the suite. + (4) Details of the usage of the COMMON blocks, including which routines + initialize, read, or alter variables in each block. + +************************ End of rksuite.doc ******************************* diff --git a/rksuite/rksuite.f b/rksuite/rksuite.f new file mode 100644 index 0000000..0ad574b --- /dev/null +++ b/rksuite/rksuite.f @@ -0,0 +1,4939 @@ + SUBROUTINE SETUP(NEQ,TSTART,YSTART,TEND,TOL,THRES,METHOD,TASK, + & ERRASS,HSTART,WORK,LENWRK,MESAGE) +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C +C If you are not familiar with the code SETUP and how it is used in +C conjunction with UT or CT to solve initial value problems, you should study +C the document file rksuite.doc carefully before attempting to use the code. +C The following "Brief Reminder" is intended only to remind you of the +C meaning, type, and size requirements of the arguments. +C +C The environmental parameters OUTCH, MCHEPS, and DWARF are used in the +C following description. To find out their values +C +C CALL ENVIRN(OUTCH,MCHEPS,DWARF) +C +C INPUT VARIABLES +C +C NEQ - INTEGER +C The number of differential equations in the system. +C Constraint: NEQ >= 1 +C TSTART - DOUBLE PRECISION +C The initial value of the independent variable. +C YSTART(*) - DOUBLE PRECISION array of length NEQ +C The vector of initial values of the solution components. +C TEND - DOUBLE PRECISION +C The integration proceeds from TSTART in the direction of +C TEND. You cannot go past TEND. +C Constraint: TEND must be clearly distinguishable from TSTART +C in the precision available. +C TOL - DOUBLE PRECISION +C The relative error tolerance. +C Constraint: 0.01D0 >= TOL >= 10*MCHEPS +C THRES(*) - DOUBLE PRECISION array of length NEQ +C THRES(L) is the threshold for the Ith solution component. +C Constraint: THRES(L) >= SQRT(DWARF) +C METHOD - INTEGER +C Specifies which Runge-Kutta pair is to be used. +C = 1 - use the (2,3) pair +C = 2 - use the (4,5) pair +C = 3 - use the (7,8) pair +C TASK - CHARACTER*(*) +C Only the first character of TASK is significant. +C TASK(1:1) = `U' or `u' - UT is to be used +C = `C' or `c' - CT is to be used +C Constraint: TASK(1:1) = `U'or `u' or`C' or `c' +C ERRASS - LOGICAL +C = .FALSE. - do not attempt to assess the true error. +C = .TRUE. - assess the true error. Costs roughly twice +C as much as the integration with METHODs 2 and +C 3, and three times with METHOD = 1. +C HSTART - DOUBLE PRECISION +C 0.0D0 - select automatically the first step size. +C non-zero - try HSTART for the first step. +C +C WORKSPACE +C +C WORK(*) - DOUBLE PRECISION array of length LENWRK +C Do not alter the contents of this array after calling SETUP. +C +C INPUT VARIABLES +C +C LENWRK - INTEGER +C Length of WORK(*): How big LENWRK must be depends +C on the task and how it is to be solved. +C +C LENWRK = 32*NEQ is sufficient for all cases. +C +C If storage is a problem, the least storage possible +C in the various cases is: +C +C If TASK = `U' or `u', then +C if ERRASS = .FALSE. and +C METHOD = 1, LENWRK must be at least 10*NEQ +C = 2 20*NEQ +C = 3 16*NEQ +C if ERRASS = .TRUE. and +C METHOD = 1, LENWRK must be at least 15*NEQ +C = 2 32*NEQ +C = 3 21*NEQ +C +C If TASK = `C' or `c', then +C if ERRASS = .FALSE. and +C METHOD = 1, LENWRK must be at least 10*NEQ +C = 2 14*NEQ +C = 3 16*NEQ +C if ERRASS = .TRUE. and +C METHOD = 1, LENWRK must be at least 15*NEQ +C = 2 26*NEQ +C = 3 21*NEQ +C +C Warning: To exploit the interpolation capability +C of METHODs 1 and 2, you have to call INTRP. This +C subroutine requires working storage in addition to +C that specified here. +C +C MESAGE - LOGICAL +C Specifies whether you want informative messages written to +C the standard output channel OUTCH. +C = .TRUE. - provide messages +C = .FALSE. - do not provide messages +C +C In the event of a "catastrophic" failure to call SETUP correctly, the +C nature of the catastrophe is reported on the standard output channel, +C regardless of the value of MESAGE. Unless special provision was made +C in advance (see rksuite.doc), the computation then comes to a STOP. +C +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C .. Scalar Arguments .. + DOUBLE PRECISION HSTART, TEND, TOL, TSTART + INTEGER LENWRK, METHOD, NEQ + LOGICAL ERRASS, MESAGE + CHARACTER*(*) TASK +C .. Array Arguments .. + DOUBLE PRECISION THRES(*), WORK(*), YSTART(*) +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block for General Workspace Pointers .. + INTEGER PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + COMMON /RKCOM3/ PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + SAVE /RKCOM3/ +C .. Common Block to hold Formula Definitions .. + DOUBLE PRECISION A(13,13), B(13), C(13), BHAT(13), R(11,6), + & E(7) + INTEGER PTR(13), NSTAGE, METHD, MINTP + LOGICAL INTP + COMMON /RKCOM4/ A, B, C, BHAT, R, E, PTR, NSTAGE, METHD, + & MINTP, INTP + SAVE /RKCOM4/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Global Error Assessment .. + DOUBLE PRECISION MAXERR, LOCMAX + INTEGER GNFCN, PRZSTG, PRZY, PRZYP, PRZERS, PRZERR, + & PRZYNU + LOGICAL ERASON, ERASFL + COMMON /RKCOM6/ MAXERR, LOCMAX, GNFCN, PRZSTG, PRZY, PRZYP, + & PRZERS, PRZERR, PRZYNU, ERASON, ERASFL + SAVE /RKCOM6/ +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Common Block for Integrator Options .. + LOGICAL MSG, UTASK + COMMON /RKCOM8/ MSG, UTASK + SAVE /RKCOM8/ +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ +C .. Parameters .. + CHARACTER*6 SRNAME + PARAMETER (SRNAME='SETUP') + INTEGER MINUS1 + LOGICAL TELL + PARAMETER (MINUS1=-1,TELL=.FALSE.) + DOUBLE PRECISION ONE, ZERO, PT01 + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0,PT01=0.01D+0) +C .. Local Scalars .. + DOUBLE PRECISION HMIN + INTEGER FLAG, FREEPR, IER, L, LINTPL, LREQ, NREC, VECSTG + LOGICAL LEGALT, REQSTG + CHARACTER TASK1 +C .. External Subroutines .. + EXTERNAL CONST, MCONST, RKMSG, RKSIT +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN +C .. Executable Statements .. +C +C Clear previous flag values of subprograms in the suite. +C + IER = MINUS1 + CALL RKSIT(TELL,SRNAME,IER) +C + IER = 1 + NREC = 0 +C +C Fetch output channel and machine constants; initialise common +C block /RKCOM7/ +C + CALL MCONST(METHOD) +C +C Check for valid input of trivial arguments + TASK1 = TASK(1:1) + LEGALT = TASK1 .EQ. 'U' .OR. TASK1 .EQ. 'u' .OR. + & TASK1 .EQ. 'C' .OR. TASK1 .EQ. 'c' + IF (.NOT.LEGALT) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A/A,A,A/A)') + &' ** You have set the first character of ', + &' ** TASK to be ''',TASK1,'''. It must be one of ', + &' ** ''U'',''u'',''C'' or ''c''.' + ELSE IF (NEQ.LT.1) THEN + IER = 911 + NREC = 1 + WRITE (REC,'(A,I6,A)') + &' ** You have set NEQ = ',NEQ,' which is less than 1.' + ELSE IF (METHOD.LT.1 .OR. METHOD.GT.3) THEN + IER = 911 + NREC = 1 + WRITE (REC,'(A,I6,A)') + &' ** You have set METHOD = ',METHOD,' which is not 1, 2, or 3.' + ELSE IF (TSTART.EQ.TEND) THEN + IER = 911 + NREC = 1 + WRITE (REC,'(A,D13.5,A)') + &' ** You have set TSTART = TEND = ',TSTART,'.' + ELSE IF ((TOL.GT.PT01) .OR. (TOL.LT.RNDOFF)) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A,D13.5,A/A,D13.5,A)') + &' ** You have set TOL = ',TOL,' which is not permitted. The', + &' ** range of permitted values is (',RNDOFF,',0.01D0).' + ELSE + L = 1 + 20 CONTINUE + IF (THRES(L).LT.TINY) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A,I6,A,D13.5,A/A,D13.5,A)') + &' ** You have set THRES(',L,') to be ',THRES(L),' which is ', + &' ** less than the permitted minimum,',TINY,'.' + END IF + L = L + 1 + IF (IER.NE.911 .AND. L.LE.NEQ) GO TO 20 + END IF +C +C Return if error detected +C + IF (IER.NE.1) GO TO 80 +C +C Set formula definitions and characteristics by means of arguments +C in the call list and COMMON blocks /RKCOM4/ and /RKCOM5/ +C + CALL CONST(METHOD,VECSTG,REQSTG,LINTPL) +C +C Set options in /RKCOM8/ + UTASK = TASK1 .EQ. 'U' .OR. TASK1 .EQ. 'u' + MSG = MESAGE +C +C Initialise problem status in /RKCOM1/ and /RKCOM2/ + NEQN = NEQ + TSTRT = TSTART + TND = TEND + T = TSTART + TOLD = TSTART + DIR = SIGN(ONE,TEND-TSTART) +C +C In CT the first step taken will have magnitude H. If HSTRT = ABS(HSTART) +C is not equal to zero, H = HSTRT. If HSTRT is equal to zero, the code is +C to find an on-scale initial step size H. To start this process, H is set +C here to an upper bound on the first step size that reflects the scale of +C the independent variable. UT has some additional information, namely the +C first output point, that is used to refine this bound in UT when UTASK +C is .TRUE.. If HSTRT is not zero, but it is either too big or too small, +C the input HSTART is ignored and HSTRT is set to zero to activate the +C automatic determination of an on-scale initial step size. +C + HSTRT = ABS(HSTART) + HMIN = MAX(TINY,TOOSML*MAX(ABS(TSTART),ABS(TEND))) + IF (HSTRT.GT.ABS(TEND-TSTART) .OR. HSTRT.LT.HMIN) HSTRT = ZERO + IF (HSTRT.EQ.ZERO) THEN + H = MAX(ABS(TEND-TSTART)/RS3,HMIN) + ELSE + H = HSTRT + END IF + HOLD = ZERO + TOLR = TOL + NFCN = 0 + SVNFCN = 0 + OKSTP = 0 + FLSTP = 0 + FIRST = .TRUE. + LAST = .FALSE. +C +C WORK(*) is partioned into a number of arrays using pointers. These +C pointers are set in /RKCOM3/. + PRTHRS = 1 +C the threshold values + PRERST = PRTHRS + NEQ +C the error estimates + PRWT = PRERST + NEQ +C the weights used in the local error test + PRYOLD = PRWT + NEQ +C the previous value of the solution + PRSCR = PRYOLD + NEQ +C scratch array used for the higher order +C approximate solution and for the previous +C value of the derivative of the solution + PRY = PRSCR + NEQ +C the dependent variables + PRYP = PRY + NEQ +C the derivatives + PRSTGS = PRYP + NEQ +C intermediate stages held in an internal +C array STAGES(NEQ,VECSTG) +C + FREEPR = PRSTGS + VECSTG*NEQ +C +C Allocate storage for interpolation if the TASK = `U' or `u' was +C specified. INTP and LINTPL returned by CONST indicate whether there +C is an interpolation scheme associated with the pair and how much +C storage is required. +C + PRINTP = 1 + LNINTP = 1 + IF (UTASK) THEN + IF (INTP) THEN + LNINTP = LINTPL*NEQ + IF (REQSTG) THEN + PRINTP = FREEPR + FREEPR = PRINTP + LNINTP + ELSE + PRINTP = PRSTGS + FREEPR = MAX(PRINTP+VECSTG*NEQ,PRINTP+LNINTP) + END IF + END IF + END IF +C +C Initialise state and allocate storage for global error assessment +C using /RKCOM6/ + GNFCN = 0 + MAXERR = ZERO + LOCMAX = TSTART + ERASON = ERRASS + ERASFL = .FALSE. + IF (ERRASS) THEN +C +C Storage is required for the stages of a secondary integration. The +C stages of the primary intergration can only be overwritten in the +C cases where there is no interpolant or the interpolant does not +C require information about the stages (e.g. METHOD 3 and METHOD 1, +C respectively). + IF (.NOT.REQSTG) THEN + PRZSTG = PRSTGS + ELSE + PRZSTG = FREEPR + FREEPR = PRZSTG + VECSTG*NEQ + END IF + PRZY = FREEPR + PRZYP = PRZY + NEQ + PRZERS = PRZYP + NEQ + PRZERR = PRZERS + NEQ + PRZYNU = PRZERR + NEQ + FREEPR = PRZYNU + NEQ + ELSE + PRZSTG = 1 + PRZY = 1 + PRZYP = 1 + PRZERS = 1 + PRZERR = 1 + PRZYNU = 1 + END IF +C + LREQ = FREEPR - 1 +C +C Check for enough workspace and suitable range of integration +C + IF (LENWRK.LT.LREQ) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A/A,I6,A,I6,A)') + &' ** You have not supplied enough workspace. You gave LENWRK ', + &' ** as', LENWRK, ', but it must be at least ',LREQ,'.' + ELSE + HMIN = MAX(TINY,TOOSML*MAX(ABS(TSTART),ABS(TEND))) + IF (ABS(TEND-TSTART).LT.HMIN) THEN + IER = 911 + NREC = 4 + WRITE (REC,'(A/A/A,D13.5/A,D13.5,A)') + &' ** You have set values for TEND and TSTART that are not ', + &' ** clearly distinguishable for the method and the precision ', + &' ** of the computer being used. ABS(TEND-TSTART) is ', + &ABS(TEND-TSTART), + &' ** but should be at least ',HMIN,'.' + END IF + END IF +C +C Return if error detected +C + IF (IER.NE.1) GO TO 80 +C +C Initialize elements of the workspace + DO 40 L = 1, NEQ + WORK(PRTHRS-1+L) = THRES(L) + WORK(PRY-1+L) = YSTART(L) + 40 CONTINUE +C +C Initialize the global error to zero when ERRASS = .TRUE. + IF (ERRASS) THEN + DO 60 L = 1, NEQ + WORK(PRZERR-1+L) = ZERO + 60 CONTINUE + END IF +C + 80 CONTINUE +C + CALL RKMSG(IER,SRNAME,NREC,FLAG) +C + RETURN + END + SUBROUTINE UT(F,TWANT,TGOT,YGOT,YPGOT,YMAX,WORK,UFLAG) +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C +C If you are not familiar with the code UT and how it is used in +C conjunction with SETUP to solve initial value problems, you should study +C the document file rksuite.doc carefully before proceeding further. The +C following "Brief Reminder" is intended only to remind you of the meaning, +C type, and size requirements of the arguments. +C +C NAME DECLARED IN AN EXTERNAL STATEMENT IN THE CALLING PROGRAM: +C +C F - name of the subroutine for evaluating the differential +C equations. +C +C The subroutine F must have the form +C +C SUBROUTINE F(T,Y,YP) +C DOUBLE PRECISION T,Y(*),YP(*) +C Given input values of the independent variable T and the solution +C components Y(*), for each L = 1,2,...,NEQ evaluate the differential +C equation for the derivative of the Ith solution component and place the +C value in YP(L). Do not alter the input values of T and Y(*). +C RETURN +C END +C +C INPUT VARIABLE +C +C TWANT - DOUBLE PRECISION +C The next value of the independent variable where a +C solution is desired. +C +C Constraints: TWANT must lie between the previous value +C of TGOT (TSTART on the first call) and TEND. TWANT can be +C equal to TEND, but it must be clearly distinguishable from +C the previous value of TGOT (TSTART on the first call) in +C the precision available. +C +C OUTPUT VARIABLES +C +C TGOT - DOUBLE PRECISION +C A solution has been computed at this value of the +C independent variable. +C YGOT(*) - DOUBLE PRECISION array of length NEQ +C Approximation to the true solution at TGOT. Do not alter +C the contents of this array +C YPGOT(*) - DOUBLE PRECISION array of length NEQ +C Approximation to the first derivative of the true +C solution at TGOT. +C YMAX(*) - DOUBLE PRECISION array of length NEQ +C YMAX(L) is the largest magnitude of YGOT(L) computed at any +C time in the integration from TSTART to TGOT. Do not alter +C the contents of this array. +C +C WORKSPACE +C +C WORK(*) - DOUBLE PRECISION array as used in SETUP +C Do not alter the contents of this array. +C +C OUTPUT VARIABLE +C +C UFLAG - INTEGER +C +C SUCCESS. TGOT = TWANT. +C = 1 - Complete success. +C +C "SOFT" FAILURES +C = 2 - Warning: You are using METHOD = 3 inefficiently +C by computing answers at many values of TWANT. If +C you really need answers at so many specific points, +C it would be more efficient to compute them with +C METHOD = 2. To do this you would need to restart +C from TGOT, YGOT(*) by a call to SETUP. If you wish +C to continue as you are, you may. +C = 3 - Warning: A considerable amount of work has been +C expended. If you wish to continue on to TWANT, just +C call UT again. +C = 4 - Warning: It appears that this problem is "stiff". +C You really should change to another code that is +C intended for such problems, but if you insist, you can +C continue with UT by calling it again. +C +C "HARD" FAILURES +C = 5 - You are asking for too much accuracy. You cannot +C continue integrating this problem. +C = 6 - The global error assessment may not be reliable beyond +C the current point in the integration. You cannot +C continue integrating this problem. +C +C "CATASTROPHIC" FAILURES +C = 911 - The nature of the catastrophe is reported on +C the standard output channel. Unless special +C provision was made in advance (see rksuite.doc), +C the computation then comes to a STOP. +C +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C .. Scalar Arguments .. + DOUBLE PRECISION TGOT, TWANT + INTEGER UFLAG +C .. Array Arguments .. + DOUBLE PRECISION WORK(*), YGOT(*), YMAX(*), YPGOT(*) +C .. Subroutine Arguments .. + EXTERNAL F +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block for General Workspace Pointers .. + INTEGER PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + COMMON /RKCOM3/ PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + SAVE /RKCOM3/ +C .. Common Block to hold Formula Definitions .. + DOUBLE PRECISION A(13,13), B(13), C(13), BHAT(13), R(11,6), + & E(7) + INTEGER PTR(13), NSTAGE, METHD, MINTP + LOGICAL INTP + COMMON /RKCOM4/ A, B, C, BHAT, R, E, PTR, NSTAGE, METHD, + & MINTP, INTP + SAVE /RKCOM4/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Common Block for Integrator Options .. + LOGICAL MSG, UTASK + COMMON /RKCOM8/ MSG, UTASK + SAVE /RKCOM8/ +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ +C .. Parameters .. + CHARACTER*6 SRNAME + PARAMETER (SRNAME='UT') + LOGICAL ASK, TELL + PARAMETER (ASK=.TRUE.,TELL=.FALSE.) + INTEGER MINUS1, MINUS2 + PARAMETER (MINUS1=-1,MINUS2=-2) + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +C .. Local Scalars .. + DOUBLE PRECISION HMIN, TLAST, TNOW, UTEND + INTEGER CFLAG, IER, L, NREC, STATE + LOGICAL BADERR, GOBACK +C .. External Subroutines .. + EXTERNAL CHKFL, CT, INTRP, RESET, RKMSG, RKSIT +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. Save statement .. + SAVE UTEND, TLAST +C .. Executable Statements .. + IER = 1 + NREC = 0 + GOBACK = .FALSE. + BADERR = .FALSE. +C +C Is it permissible to call UT? +C + CALL RKSIT(ASK,'SETUP',STATE) + IF (STATE.EQ.911) THEN + IER = 912 + NREC = 1 + WRITE (REC,'(A)') + &' ** A catastrophic error has already been detected elsewhere.' + GO TO 100 + END IF + IF (STATE.EQ.MINUS1) THEN + IER = 911 + NREC = 1 + WRITE (REC,'(A)') + &' ** You have not called SETUP, so you cannot use UT.' + GO TO 100 + END IF + IF (.NOT.UTASK) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A/A)') + &' ** You have called UT after you specified in SETUP that ', + &' ** you were going to use CT. This is not permitted.' + GO TO 100 + END IF + CALL RKSIT(ASK,SRNAME,STATE) + IF (STATE.EQ.5 .OR. STATE.EQ.6) THEN + IER = 911 + NREC = 1 + WRITE (REC,'(A/A)') + &' ** This routine has already returned with a hard failure.', + &' ** You must call SETUP to start another problem.' + GO TO 100 + END IF + STATE = MINUS2 + CALL RKSIT(TELL,SRNAME,STATE) +C + IF (FIRST) THEN +C +C First call. +C +C A value of TND is specified in SETUP. When INTP = .FALSE., as with +C METHD = 3, output is obtained at the specified TWANT by resetting TND +C to TWANT. At this point, before the integration gets started, this can +C be done with a simple assignment. Later it is done with a call to RESET. +C The original TND is SAVEd as a local variable UTEND. +C + UTEND = TND + IF (.NOT.INTP) TND = TWANT +C +C The last TGOT returned is SAVEd in the variable TLAST. T (a variable +C passed through the common block RKCOM2) records how far the integration +C has advanced towards the specified TND. When output is obtained by +C interpolation, the integration goes past the TGOT returned (T is closer +C to the specified TND than TGOT). Initialize these variables and YMAX(*). + TLAST = TSTRT + TGOT = TSTRT + DO 20 L = 1, NEQN + YMAX(L) = ABS(WORK(PRY-1+L)) + 20 CONTINUE +C +C If the code is to find an on-scale initial step size H, a bound was placed +C on H in SETUP. Here the first output point is used to refine this bound. + IF (HSTRT.EQ.ZERO) THEN + H = MIN(ABS(H),ABS(TWANT-TSTRT)) + HMIN = MAX(TINY,TOOSML*MAX(ABS(TSTRT),ABS(TND))) + H = MAX(H,HMIN) + END IF +C + ELSE +C +C Subsequent call. +C + IF (TLAST.EQ.UTEND) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A/A/A)') + &' ** You have called UT after reaching TEND. (Your last ', + &' ** call to UT resulted in TGOT = TEND.) To start a new ', + &' ** problem, you will need to call SETUP.' + GO TO 100 + END IF +C + END IF +C +C Check for valid TWANT. +C + IF (DIR*(TWANT-TLAST).LE.ZERO) THEN + IER = 911 + NREC = 4 + WRITE (REC,'(A/A/A/A)') + &' ** You have made a call to UT with a TWANT that does ', + &' ** not lie between the previous value of TGOT (TSTART ', + &' ** on the first call) and TEND. This is not permitted. ', + &' ** Check your program carefully.' + GO TO 100 + END IF + IF (DIR*(TWANT-UTEND).GT.ZERO) THEN + HMIN = MAX(TINY,TOOSML*MAX(ABS(TWANT),ABS(UTEND))) + IF (ABS(TWANT-UTEND).LT.HMIN) THEN + IER = 911 + NREC = 5 + WRITE (REC,'(A/A/A/A)') + &' ** You have made a call to UT with a TWANT that does ', + &' ** not lie between the previous value of TGOT (TSTART on ', + &' ** the first call) and TEND. This is not permitted. TWANT ', + &' ** is very close to TEND, so you may have meant to set ', + &' ** it to be TEND exactly. Check your program carefully. ' + ELSE + IER = 911 + NREC = 4 + WRITE (REC,'(A/A/A/A)') + &' ** You have made a call to UT with a TWANT that does ', + &' ** not lie between the previous value of TGOT (TSTART ', + &' ** on the first call) and TEND. This is not permitted. ', + &' ** Check your program carefully.' + END IF + GO TO 100 + END IF + IF (.NOT.INTP) THEN + HMIN = MAX(TINY,TOOSML*MAX(ABS(TLAST),ABS(TWANT))) + IF (ABS(TWANT-TLAST).LT.HMIN) THEN + IER = 911 + NREC = 4 + WRITE (REC,'(A/A/A/A,D13.5,A)') + &' ** You have made a call to UT with a TWANT that is not ', + &' ** sufficiently different from the last value of TGOT ', + &' ** (TSTART on the first call). When using METHOD = 3, ', + &' ** it must differ by at least ',HMIN,'.' + GO TO 100 + END IF +C +C We have a valid TWANT. There is no interpolation with this METHD and +C therefore we step to TWANT exactly by resetting TND with a call to RESET. +C On the first step this matter is handled differently as explained above. +C + IF (.NOT.FIRST) THEN + CALL RESET(TWANT) + CALL CHKFL(ASK,BADERR) + IF (BADERR) GO TO 100 + END IF + END IF +C +C Process output, decide whether to take another step. +C + 40 CONTINUE +C + IF (INTP) THEN +C +C Interpolation is possible with this METHD. The integration has +C already reached T. If this is past TWANT, GOBACK is set .TRUE. and +C the answers are obtained by interpolation. +C + GOBACK = DIR*(T-TWANT) .GE. ZERO + IF (GOBACK) THEN + CALL INTRP(TWANT,'Both solution and derivative',NEQN,YGOT, + & YPGOT,F,WORK,WORK(PRINTP),LNINTP) + CALL CHKFL(ASK,BADERR) + IF (BADERR) GO TO 100 + TGOT = TWANT + END IF + ELSE +C +C Interpolation is not possible with this METHD, so output is obtained +C by integrating to TWANT = TND. Both YGOT(*) and YPGOT(*) are then +C already loaded with the solution at TWANT by CT. +C + GOBACK = T .EQ. TWANT + IF (GOBACK) TGOT = TWANT + END IF +C +C Updating of YMAX(*) is done here to account for the fact that when +C interpolation is done, the integration goes past TGOT. Note that YGOT(*) +C is not defined until CT is called. YMAX(*) was initialized at TSTRT +C from values stored in WORK(*), so only needs to be updated for T +C different from TSTRT. + IF (T.NE.TSTRT) THEN + DO 60 L = 1, NEQN + YMAX(L) = MAX(YMAX(L),ABS(YGOT(L))) + 60 CONTINUE + END IF +C +C If done, go to the exit point. + IF (GOBACK) GO TO 100 +C +C Take a step with CT in the direction of TND. On exit, the solution is +C advanced to TNOW. The way CT is written, the approximate solution at +C TNOW is available in both YGOT(*) and in WORK(*). If output is obtained by +C stepping to the end (TNOW = TWANT = TND), YGOT(*) can be returned directly. +C If output is obtained by interpolation, the subroutine INTRP that does this +C uses the values in WORK(*) for its computations and places the approximate +C solution at TWANT in the array YGOT(*) for return to the calling program. +C The approximate derivative is handled in the same way. TNOW is output from +C CT and is actually a copy of T declared above in a common block. +C + CALL CT(F,TNOW,YGOT,YPGOT,WORK,CFLAG) + IER = CFLAG +C +C A successful step by CT is indicated by CFLAG = 1 or = 2. + IF (CFLAG.EQ.1) THEN + GO TO 40 + ELSE IF (CFLAG.EQ.2) THEN +C +C Supplement the warning message written in CT. + NREC = 3 + WRITE (REC,'(A/A/A)') + &' ** The last message was produced on a call to CT from UT. ', + &' ** In UT the appropriate action is to change to METHOD = 2,', + &' ** or, if insufficient memory is available, to METHOD = 1. ' + ELSE IF (CFLAG.LE.6) THEN + NREC = 1 + WRITE (REC,'(A)') + &' ** The last message was produced on a call to CT from UT.' + ELSE + BADERR = .TRUE. + END IF + TGOT = T +C +C Update YMAX(*) before the return. + DO 80 L = 1, NEQN + YMAX(L) = MAX(YMAX(L),ABS(YGOT(L))) + 80 CONTINUE +C +C Exit point for UT. +C + 100 CONTINUE +C + IF (BADERR) THEN + IER = 911 + NREC = 4 + WRITE (REC,'(A/A/A/A)') + &' ** An internal call by UT to a subroutine resulted in an ', + &' ** error that should not happen. Check your program ', + &' ** carefully for array sizes, correct number of arguments,', + &' ** type mismatches ... .' + END IF +C + TLAST = TGOT +C +C All exits are done here after a call to RKMSG to report +C what happened and set UFLAG. +C + CALL RKMSG(IER,SRNAME,NREC,UFLAG) +C + RETURN + END + SUBROUTINE STAT(TOTFCN,STPCST,WASTE,STPSOK,HNEXT) +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C +C If you are not familiar with the code STAT and how it is used in +C conjunction with the integrators CT and UT, you should study the +C document file rksuite.doc carefully before attempting to use the code. +C The following "Brief Reminder" is intended only to remind you of the +C meaning, type, and size requirements of the arguments. +C +C STAT is called to obtain some details about the integration. +C +C OUTPUT VARIABLES +C +C TOTFCN - INTEGER +C Total number of calls to F in the integration so far -- +C a measure of the cost of the integration. +C STPCST - INTEGER +C Cost of a typical step with this METHOD measured in +C calls to F. +C WASTE - DOUBLE PRECISION +C The number of attempted steps that failed to meet the +C local error requirement divided by the total number of +C steps attempted so far in the integration. +C STPSOK - INTEGER +C The number of accepted steps. +C HNEXT - DOUBLE PRECISION +C The step size the integrator plans to use for the next step. +C +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C .. Scalar Arguments .. + DOUBLE PRECISION HNEXT, WASTE + INTEGER STPCST, STPSOK, TOTFCN +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Global Error Assessment .. + DOUBLE PRECISION MAXERR, LOCMAX + INTEGER GNFCN, PRZSTG, PRZY, PRZYP, PRZERS, PRZERR, + & PRZYNU + LOGICAL ERASON, ERASFL + COMMON /RKCOM6/ MAXERR, LOCMAX, GNFCN, PRZSTG, PRZY, PRZYP, + & PRZERS, PRZERR, PRZYNU, ERASON, ERASFL + SAVE /RKCOM6/ +C .. Common Block for Integrator Options .. + LOGICAL MSG, UTASK + COMMON /RKCOM8/ MSG, UTASK + SAVE /RKCOM8/ +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ +C .. Parameters .. + CHARACTER*6 SRNAME + PARAMETER (SRNAME='STAT') + LOGICAL ASK + INTEGER MINUS1, MINUS2 + PARAMETER (ASK=.TRUE.,MINUS1=-1,MINUS2=-2) + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +C .. Local Scalars .. + INTEGER FLAG, IER, NREC, STATE +C .. External Subroutines .. + EXTERNAL RKMSG, RKSIT +C .. Intrinsic Functions .. + INTRINSIC DBLE +C .. Executable Statements .. +C + IER = 1 + NREC = 0 +C +C Is it permissible to call STAT? +C + CALL RKSIT(ASK,SRNAME,STATE) + IF (STATE.EQ.911) THEN + IER = 912 + NREC = 1 + WRITE (REC,'(A)') + &' ** A catastrophic error has already been detected elsewhere.' + GO TO 20 + END IF + IF (STATE.EQ.MINUS2) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A/A/A)') + &' ** You have already made a call to STAT after a hard ', + &' ** failure was reported from the integrator. You cannot', + &' ** call STAT again.' + GO TO 20 + END IF + CALL RKSIT(ASK,'CT',STATE) + IF (STATE.EQ.MINUS1) THEN + IER = 911 + NREC = 1 + IF (UTASK) THEN + WRITE (REC,'(A)') + &' ** You have not called UT, so you cannot use STAT.' + ELSE + WRITE (REC,'(A)') + &' ** You have not called CT, so you cannot use STAT.' + END IF + GO TO 20 + END IF +C +C Set flag so that the routine can only be called once after a hard +C failure from the integrator. + IF (STATE.EQ.5 .OR. STATE.EQ.6) IER = MINUS2 +C + TOTFCN = SVNFCN + NFCN + IF (ERASON) TOTFCN = TOTFCN + GNFCN + STPCST = COST + STPSOK = OKSTP + IF (OKSTP.LE.1) THEN + WASTE = ZERO + ELSE + WASTE = DBLE(FLSTP)/DBLE(FLSTP+OKSTP) + END IF + HNEXT = H +C + 20 CONTINUE +C + CALL RKMSG(IER,SRNAME,NREC,FLAG) +C + RETURN + END + SUBROUTINE GLBERR(RMSERR,ERRMAX,TERRMX,WORK) +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C +C If you are not familiar with the code GLBERR and how it is used in +C conjunction with UT and CT to solve initial value problems, you should +C study the document file rksuite.doc carefully before attempting to use +C the code. The following "Brief Reminder" is intended only to remind you +C of the meaning, type, and size requirements of the arguments. +C +C If ERRASS was set .TRUE. in the call to SETUP, then after any call to UT +C or CT to advance the integration to TNOW or TWANT, the subroutine GLBERR +C may be called to obtain an assessment of the true error of the integration. +C At each step and for each solution component Y(L), a more accurate "true" +C solution YT(L), an average magnitude "size(L)" of its size, and its error +C abs(Y(L) - YT(L))/max("size(L)",THRES(L)) +C are computed. The assessment returned in RMSERR(L) is the RMS (root-mean- +C square) average of the error in the Lth solution component over all steps +C of the integration from TSTART through TNOW. +C +C OUTPUT VARIABLES +C +C RMSERR(*) - DOUBLE PRECISION array of length NEQ +C RMSERR(L) approximates the RMS average of the true error +C of the numerical solution for the Ith solution component, +C L = 1,2,...,NEQ. The average is taken over all steps from +C TSTART to TNOW. +C ERRMAX - DOUBLE PRECISION +C The maximum (approximate) true error taken over all +C solution components and all steps from TSTART to TNOW. +C TERRMX - DOUBLE PRECISION +C First value of the independent variable where the +C (approximate) true error attains the maximum value ERRMAX. +C +C WORKSPACE +C +C WORK(*) - DOUBLE PRECISION array as used in SETUP and UT or CT +C Do not alter the contents of this array. +C +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C .. Scalar Arguments .. + DOUBLE PRECISION ERRMAX, TERRMX +C .. Array Arguments .. + DOUBLE PRECISION RMSERR(*), WORK(*) +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block for Global Error Assessment .. + DOUBLE PRECISION MAXERR, LOCMAX + INTEGER GNFCN, PRZSTG, PRZY, PRZYP, PRZERS, PRZERR, + & PRZYNU + LOGICAL ERASON, ERASFL + COMMON /RKCOM6/ MAXERR, LOCMAX, GNFCN, PRZSTG, PRZY, PRZYP, + & PRZERS, PRZERR, PRZYNU, ERASON, ERASFL + SAVE /RKCOM6/ +C .. Common Block for Integrator Options .. + LOGICAL MSG, UTASK + COMMON /RKCOM8/ MSG, UTASK + SAVE /RKCOM8/ +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ +C .. Parameters .. + CHARACTER*6 SRNAME + PARAMETER (SRNAME='GLBERR') + LOGICAL ASK + PARAMETER (ASK=.TRUE.) + INTEGER MINUS1, MINUS2 + PARAMETER (MINUS1=-1,MINUS2=-2) +C .. Local Scalars .. + INTEGER FLAG, IER, L, NREC, STATE +C .. External Subroutines .. + EXTERNAL RKMSG, RKSIT +C .. Intrinsic Functions .. + INTRINSIC SQRT +C .. Executable Statements .. +C + IER = 1 + NREC = 0 +C +C Is it permissible to call GLBERR? +C + CALL RKSIT(ASK,SRNAME,STATE) + IF (STATE.EQ.911) THEN + IER = 912 + NREC = 1 + WRITE (REC,'(A)') + &' ** A catastrophic error has already been detected elsewhere.' + GO TO 40 + END IF + IF (STATE.EQ.MINUS2) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A/A/A)') + &' ** You have already made a call to GLBERR after a hard ', + &' ** failure was reported from the integrator. You cannot', + &' ** call GLBERR again.' + GO TO 40 + END IF + CALL RKSIT(ASK,'CT',STATE) + IF (STATE.EQ.MINUS1) THEN + IER = 911 + NREC = 1 + IF (UTASK) THEN + WRITE (REC,'(A)') + &' ** You have not yet called UT, so you cannot call GLBERR.' + ELSE + WRITE (REC,'(A)') + &' ** You have not yet called CT, so you cannot call GLBERR.' + END IF + GO TO 40 + END IF +C +C Set flag so that the routine can only be called once after a hard +C failure from the integrator. + IF (STATE.EQ.5 .OR. STATE.EQ.6) IER = MINUS2 +C +C Check that ERRASS was set properly for error assessment in SETUP. +C + IF (.NOT.ERASON) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A/A/A)') + &' ** No error assessment is available since you did not ', + &' ** ask for it in your call to the routine SETUP.', + &' ** Check your program carefully.' + GO TO 40 + END IF +C +C Check to see if the integrator has not actually taken a step. +C + IF (OKSTP.EQ.0) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A/A/A)') + &' ** The integrator has not actually taken any successful ', + &' ** steps. You cannot call GLBERR in this circumstance. ', + &' ** Check your program carefully.' + GO TO 40 + END IF +C +C Compute RMS error and set output variables. +C + ERRMAX = MAXERR + TERRMX = LOCMAX + DO 20 L = 1, NEQN + RMSERR(L) = SQRT(WORK(PRZERR-1+L)/OKSTP) + 20 CONTINUE +C + 40 CONTINUE +C + CALL RKMSG(IER,SRNAME,NREC,FLAG) +C + RETURN + END + SUBROUTINE CT(F,TNOW,YNOW,YPNOW,WORK,CFLAG) +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C +C If you are not familiar with the code CT and how it is used in +C conjunction with SETUP to solve initial value problems, you should study +C the document file rksuite.doc carefully before attempting to use the code. +C The following "Brief Reminder" is intended only to remind you of the +C meaning, type, and size requirements of the arguments. +C +C NAME DECLARED IN AN EXTERNAL STATEMENT IN THE CALLING PROGRAM: +C +C F - name of the subroutine for evaluating the differential +C equations. +C +C The subroutine F must have the form +C +C SUBROUTINE F(T,Y,YP) +C DOUBLE PRECISION T,Y(*),YP(*) +C Using the input values of the independent variable T and the solution +C components Y(*), for each L = 1,2,...,NEQ evaluate the differential +C equation for the derivative of the Lth solution component and place the +C value in YP(L). Do not alter the input values of T and Y(*). +C RETURN +C END +C +C OUTPUT VARIABLES +C +C TNOW - DOUBLE PRECISION +C Current value of the independent variable. +C YNOW(*) - DOUBLE PRECISION array of length NEQ +C Approximation to the true solution at TNOW. +C YPNOW(*) - DOUBLE PRECISION array of length NEQ +C Approximation to the first derivative of the +C true solution at TNOW. +C +C WORKSPACE +C +C WORK(*) - DOUBLE PRECISION array as used in SETUP +C Do not alter the contents of this array. +C +C OUTPUT VARIABLE +C +C CFLAG - INTEGER +C +C SUCCESS. A STEP WAS TAKEN TO TNOW. +C = 1 - Complete success. +C +C "SOFT" FAILURES +C = 2 - Warning: You have obtained an answer by integrating +C to TEND (TNOW = TEND). You have done this at least +C 100 times, and monitoring of the computation reveals +C that this way of getting output has degraded the +C efficiency of the code. If you really need answers at +C so many specific points, it would be more efficient to +C get them with INTRP. (If METHOD = 3, you would need +C to change METHOD and restart from TNOW, YNOW(*) by a +C call to SETUP.) If you wish to continue as you are, +C you may. +C = 3 - Warning: A considerable amount of work has been +C expended. To continue the integration, just call +C CT again. +C = 4 - Warning: It appears that this problem is "stiff". +C You really should change to another code that is +C intended for such problems, but if you insist, you +C can continue with CT by calling it again. +C +C "HARD" FAILURES +C = 5 - You are asking for too much accuracy. You cannot +C continue integrating this problem. +C = 6 - The global error assessment may not be reliable beyond +C the current point in the integration. You cannot +C continue integrating this problem. +C +C "CATASTROPHIC" FAILURES +C = 911 - The nature of the catastrophe is reported on +C the standard output channel. Unless special +C provision was made in advance (see rksuite.doc), +C the computation then comes to a STOP. +C +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C .. Scalar Arguments .. + DOUBLE PRECISION TNOW + INTEGER CFLAG +C .. Array Arguments .. + DOUBLE PRECISION WORK(*), YNOW(*), YPNOW(*) +C .. Subroutine Arguments .. + EXTERNAL F +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block for General Workspace Pointers .. + INTEGER PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + COMMON /RKCOM3/ PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + SAVE /RKCOM3/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Global Error Assessment .. + DOUBLE PRECISION MAXERR, LOCMAX + INTEGER GNFCN, PRZSTG, PRZY, PRZYP, PRZERS, PRZERR, + & PRZYNU + LOGICAL ERASON, ERASFL + COMMON /RKCOM6/ MAXERR, LOCMAX, GNFCN, PRZSTG, PRZY, PRZYP, + & PRZERS, PRZERR, PRZYNU, ERASON, ERASFL + SAVE /RKCOM6/ +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Common Block for Integrator Options .. + LOGICAL MSG, UTASK + COMMON /RKCOM8/ MSG, UTASK + SAVE /RKCOM8/ +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ +C .. Parameters .. + CHARACTER*6 SRNAME + PARAMETER (SRNAME='CT') + LOGICAL ASK, TELL + PARAMETER (ASK=.TRUE.,TELL=.FALSE.) + INTEGER MINUS1, MINUS2 + PARAMETER (MINUS1=-1,MINUS2=-2) + INTEGER MAXFCN + PARAMETER (MAXFCN=5000) + DOUBLE PRECISION ZERO, PT1, PT9, ONE, TWO, HUNDRD + PARAMETER (ZERO=0.0D+0,PT1=0.1D+0,PT9=0.9D+0,ONE=1.0D+0, + & TWO=2.0D+0,HUNDRD=100.0D+0) +C .. Local Scalars .. + DOUBLE PRECISION ALPHA, BETA, ERR, ERROLD, HAVG, HMIN, HTRY, TAU, + & TEMP1, TEMP2, YPNORM + INTEGER IER, JFLSTP, L, NREC, NTEND, POINT, STATE, YNEW, + & YPOLD + LOGICAL CHKEFF, FAILED, MAIN, PHASE1, PHASE2, PHASE3, + & TOOMCH +C .. External Subroutines .. + EXTERNAL RKMSG, RKSIT, STEP, STIFF, TRUERR +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SIGN +C .. Save statement .. + SAVE JFLSTP, NTEND, ERROLD, HAVG, PHASE2, YNEW, + & YPOLD, CHKEFF +C .. Executable Statements .. +C + IER = 1 + NREC = 0 +C +C Is it permissible to call CT? +C + CALL RKSIT(ASK,'SETUP',STATE) + IF (STATE.EQ.911) THEN + IER = 912 + NREC = 1 + WRITE (REC,'(A)') + &' ** A catastrophic error has already been detected elsewhere.' + GO TO 180 + END IF + IF (STATE.EQ.MINUS1) THEN + IER = 911 + NREC = 1 + WRITE (REC,'(A)') + &' ** You have not called SETUP, so you cannot use CT.' + GO TO 180 + END IF + IF (UTASK) THEN + CALL RKSIT(ASK,'UT',STATE) + IF (STATE.NE.MINUS2) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A/A)') + &' ** You have called CT after you specified in SETUP that ', + &' ** you were going to use UT. This is not permitted.' + UTASK = .FALSE. + GO TO 180 + END IF + END IF + CALL RKSIT(ASK,SRNAME,STATE) + IF (STATE.EQ.5 .OR. STATE.EQ.6) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A/A)') + &' ** CT has already returned with a flag value of 5 or 6.', + &' ** You cannot continue integrating this problem. You must ', + &' ** call SETUP to start another problem.' + GO TO 180 + END IF +C + IF (FIRST) THEN +C +C First call in an integration -- initialize everything. +C + CHKEFF = .FALSE. + NTEND = 0 + JFLSTP = 0 +C +C A scratch area of WORK(*) starting at PRSCR is used to hold two +C arrays in this subroutine: the higher order approximate solution at +C the end of a step and the approximate derivative of the solution at +C the end of the last step. To make this clear, local pointers YNEW and +C YPOLD are used. + YNEW = PRSCR + YPOLD = PRSCR +C +C For this first step T was initialized to TSTRT in SETUP and the +C starting values YSTART(*) were loaded into the area of WORK(*) reserved +C for the current solution approximation starting at location PRY. The +C derivative is now computed and stored in WORK(*) starting at PRYP. +C Subsequently these arrays are copied to the output vectors YNOW(*) +C and YPNOW(*). + CALL F(T,WORK(PRY),WORK(PRYP)) + NFCN = NFCN + 1 + DO 20 L = 1, NEQN + YNOW(L) = WORK(PRY-1+L) + YPNOW(L) = WORK(PRYP-1+L) + 20 CONTINUE +C +C Set dependent variables for error assessment. + IF (ERASON) THEN + DO 40 L = 1, NEQN + WORK(PRZY-1+L) = YNOW(L) + WORK(PRZYP-1+L) = YPNOW(L) + 40 CONTINUE + END IF +C +C The weights for the control of the error depend on the size of the +C solution at the beginning and at the end of the step. On the first +C step we do not have all this information. Whilst determining the +C initial step size we initialize the weight vector to the larger of +C abs(Y(L)) and the threshold for this component. + DO 60 L = 1, NEQN + WORK(PRWT-1+L) = MAX(ABS(YNOW(L)),WORK(PRTHRS-1+L)) + 60 CONTINUE +C +C If HSTRT is equal to zero, the code is to find an on-scale initial step +C size H. CT has an elaborate scheme of three phases for finding such an H, +C and some preparations are made earlier. In SETUP an upper bound is placed +C on H that reflects the scale of the independent variable. When UTASK is +C .TRUE., UT refines this bound using the first output point. Here in CT +C PHASE1 applies a rule of thumb based on the error control, the order of the +C the formula, and the size of the initial slope to get a crude approximation +C to an on-scale H. PHASE2 may reduce H in the course of taking the first +C step. PHASE3 repeatedly adjusts H and retakes the first step until H is +C on scale. +C +C A guess for the magnitude of the first step size H can be provided to SETUP +C as HSTART. If it is too big or too small, it is ignored and the automatic +C determination of an on-scale initial step size is activated. If it is +C acceptable, H is set to HSTART in SETUP. Even when H is supplied to CT, +C PHASE3 of the scheme for finding an on-scale initial step size is made +C active so that the code can deal with a bad guess. +C + PHASE1 = HSTRT .EQ. ZERO + PHASE2 = PHASE1 + PHASE3 = .TRUE. + IF (PHASE1) THEN + H = ABS(H) + YPNORM = ZERO + DO 80 L = 1, NEQN + IF (ABS(YNOW(L)).NE.ZERO) THEN + YPNORM = MAX(YPNORM,ABS(YPNOW(L))/WORK(PRWT-1+L)) + END IF + 80 CONTINUE + TAU = TOLR**EXPON + IF (H*YPNORM.GT.TAU) H = TAU/YPNORM + HMIN = MAX(TINY,TOOSML*MAX(ABS(TSTRT),ABS(TND))) + H = DIR*MAX(H,HMIN) + PHASE1 = .FALSE. + END IF +C + ELSE +C +C Continuation call +C + IF (LAST) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A,D13.5,A/A/A)') + &' ** You have already reached TEND ( = ', TND, ').', + &' ** To integrate further with the same problem you must ', + &' ** call the routine RESET with a new value of TEND.' + GO TO 180 + END IF + END IF +C +C Begin computation of a step here. +C + FAILED = .FALSE. +C + 100 CONTINUE + H = SIGN(ABS(H),DIR) +C +C Reduce the step size if necessary so that the code will not step +C past TND. "Look ahead" to prevent unnecessarily small step sizes. + LAST = DIR*((T+H)-TND) .GE. ZERO + IF (LAST) THEN + H = TND - T + ELSE IF (DIR*((T+TWO*H)-TND).GE.ZERO) THEN + H = (TND-T)/TWO + END IF +C +C When the integrator is at T and attempts a step of H, the function +C defining the differential equations will be evaluated at a number of +C arguments between T and T+H. If H is too small, these arguments cannot +C be clearly distinguished in the precision available. +C + HMIN = MAX(TINY,TOOSML*MAX(ABS(T),ABS(T+H))) + IF (ABS(H).LT.HMIN) THEN + IER = 5 + NREC = 3 + WRITE (REC,'(A/A,D13.5,A,D13.5/A)') + &' ** In order to satisfy your error requirements CT would ', + &' ** have to use a step size of ',H,' at TNOW = ',T, + &' ** This is too small for the machine precision.' + GO TO 180 + END IF +C +C Monitor the impact of output on the efficiency of the integration. +C + IF (CHKEFF) THEN + NTEND = NTEND + 1 + IF (NTEND.GE.100 .AND. NTEND.GE.OKSTP/3) THEN + IER = 2 + NREC = 6 + WRITE (REC,'(A/A/A/A/A/A)') + &' ** More than 100 output points have been obtained by ', + &' ** integrating to TEND. They have been sufficiently close ', + &' ** to one another that the efficiency of the integration has ', + &' ** been degraded. It would probably be (much) more efficient ', + &' ** to obtain output by interpolating with INTRP (after ', + &' ** changing to METHOD=2 if you are using METHOD = 3).' + NTEND = 0 + GO TO 180 + END IF + END IF +C +C Check for stiffness and for too much work. Stiffness can be +C checked only after a successful step. +C + IF (.NOT.FAILED) THEN +C +C Check for too much work. + TOOMCH = NFCN .GT. MAXFCN + IF (TOOMCH) THEN + IER = 3 + NREC = 3 + WRITE (REC,'(A,I6,A/A/A)') + &' ** Approximately ',MAXFCN,' function evaluations have been ', + &' ** used to compute the solution since the integration ', + &' ** started or since this message was last printed.' +C +C After this warning message, NFCN is reset to permit the integration +C to continue. The total number of function evaluations in the primary +C integration is SVNFCN + NFCN. + SVNFCN = SVNFCN + NFCN + NFCN = 0 + END IF +C +C Check for stiffness. NREC is passed on to STIFF because when +C TOOMCH = .TRUE. and stiffness is diagnosed, the message about too +C much work is augmented inside STIFF to explain that it is due to +C stiffness. + CALL STIFF(F,HAVG,JFLSTP,TOOMCH,MAXFCN,WORK,IER,NREC) +C + IF (IER.NE.1) GO TO 180 + END IF +C +C Take a step. Whilst finding an on-scale H (PHASE2 = .TRUE.), the input +C value of H might be reduced (repeatedly), but it will not be reduced +C below HMIN. The local error is estimated, a weight vector is formed, +C and a weighted maximum norm, ERR, of the local error is returned. +C The variable MAIN is input as .TRUE. to tell STEP that this is the +C primary, or "main", integration. +C +C H resides in the common block /RKCOM2/ which is used by both CT and STEP; +C since it may be changed inside STEP, a local copy is made to ensure +C portability of the code. +C + MAIN = .TRUE. + HTRY = H + CALL STEP(F,NEQN,T,WORK(PRY),WORK(PRYP),WORK(PRSTGS),TOLR,HTRY, + & WORK(PRWT),WORK(YNEW),WORK(PRERST),ERR,MAIN,HMIN, + & WORK(PRTHRS),PHASE2) + H = HTRY +C +C Compare the norm of the local error to the tolerance. +C + IF (ERR.GT.TOLR) THEN +C +C Failed step. Reduce the step size and try again. +C +C First step: Terminate PHASE3 of the search for an on-scale step size. +C The step size is not on scale, so ERR may not be accurate; +C reduce H by a fixed factor. Failed attempts to take the +C first step are not counted. +C Later step: Use ERR to compute an "optimal" reduction of H. More than +C one failure indicates a difficulty with the problem and an +C ERR that may not be accurate, so reduce H by a fixed factor. +C + IF (FIRST) THEN + PHASE3 = .FALSE. + ALPHA = RS1 + ELSE + FLSTP = FLSTP + 1 + JFLSTP = JFLSTP + 1 + IF (FAILED) THEN + ALPHA = RS1 + ELSE + ALPHA = SAFETY*(TOLR/ERR)**EXPON + ALPHA = MAX(ALPHA,RS1) + END IF + END IF + H = ALPHA*H + FAILED = .TRUE. + GO TO 100 + END IF +C +C Successful step. +C +C Predict a step size appropriate for the next step. After the first +C step the prediction can be refined using an idea of H.A. Watts that +C takes account of how well the prediction worked on the previous step. + BETA = (ERR/TOLR)**EXPON + IF (.NOT.FIRST) THEN + TEMP1 = (ERR**EXPON)/H + TEMP2 = (ERROLD**EXPON)/HOLD + IF (TEMP1.LT.TEMP2*HUNDRD .AND. TEMP2.LT.TEMP1*HUNDRD) THEN + BETA = BETA*(TEMP1/TEMP2) + END IF + END IF + ALPHA = RS3 + IF (SAFETY.LT.BETA*ALPHA) ALPHA = SAFETY/BETA +C +C On the first step a search is made for an on-scale step size. PHASE2 +C of the scheme comes to an end here because a step size has been found +C that is both successful and has a credible local error estimate. Except +C in the special case that the first step is also the last, the step is +C repeated in PHASE3 as long as an increase greater than RS2 appears +C possible. An increase as big as RS3 is permitted. A step failure +C terminates PHASE3. +C + IF (FIRST) THEN + PHASE2 = .FALSE. + PHASE3 = PHASE3 .AND. .NOT. LAST .AND. (ALPHA.GT.RS2) + IF (PHASE3) THEN + H = ALPHA*H + GO TO 100 + END IF + END IF +C +C After getting on scale, step size changes are more restricted. + ALPHA = MIN(ALPHA,RS) + IF (FAILED) ALPHA = MIN(ALPHA,ONE) + ALPHA = MAX(ALPHA,RS1) + HOLD = H + H = ALPHA*H +C +C For the diagnosis of stiffness, an average accepted step size, HAVG, +C must be computed and SAVEd. + IF (FIRST) THEN + HAVG = HOLD + ELSE + HAVG = PT9*HAVG + PT1*HOLD + END IF +C + FIRST = .FALSE. + ERROLD = ERR + TOLD = T +C +C Take care that T is set to precisely TND when the end of the +C integration is reached. + IF (LAST) THEN + T = TND + ELSE + T = T + HOLD + END IF +C +C Increment counter on accepted steps. Note that successful steps +C that are repeated whilst getting on scale are not counted. + OKSTP = OKSTP + 1 +C +C Advance the current solution and its derivative. (Stored in WORK(*) +C with the first location being PRY and PRYP, respectively.) Update the +C previous solution and its derivative. (Stored in WORK(*) with the first +C location being PRYOLD and YPOLD, respectively.) Note that the previous +C derivative will overwrite YNEW(*). +C + DO 120 L = 1, NEQN + WORK(PRYOLD-1+L) = WORK(PRY-1+L) + WORK(PRY-1+L) = WORK(YNEW-1+L) + WORK(YPOLD-1+L) = WORK(PRYP-1+L) + 120 CONTINUE +C + IF (FSAL) THEN +C +C When FSAL = .TRUE., YP(*) is the last stage of the step. + POINT = PRSTGS + (LSTSTG-1)*NEQN + DO 140 L = 1, NEQN + WORK(PRYP-1+L) = WORK(POINT-1+L) + 140 CONTINUE + ELSE +C +C Call F to evaluate YP(*). + CALL F(T,WORK(PRY),WORK(PRYP)) + NFCN = NFCN + 1 + END IF +C +C If global error assessment is desired, advance the secondary +C integration from TOLD to T. +C + IF (ERASON) THEN + CALL TRUERR(F,NEQN,WORK(PRY),TOLR,WORK(PRWT),WORK(PRZY), + & WORK(PRZYP),WORK(PRZERR),WORK(PRZYNU),WORK(PRZERS), + & WORK(PRZSTG),IER) + IF (IER.EQ.6) THEN +C +C The global error estimating procedure has broken down. Treat it as a +C failed step. The solution and derivative are reset to their values at +C the beginning of the step since the last valid error assessment refers +C to them. + OKSTP = OKSTP - 1 + ERASFL = .TRUE. + LAST = .FALSE. + T = TOLD + H = HOLD + DO 160 L = 1, NEQN + WORK(PRY-1+L) = WORK(PRYOLD-1+L) + WORK(PRYP-1+L) = WORK(YPOLD-1+L) + 160 CONTINUE + IF (OKSTP.GT.1) THEN + NREC = 2 + WRITE (REC,'(A/A,D13.5,A)') + &' ** The global error assessment may not be reliable for T past ', + &' ** TNOW = ',T,'. The integration is being terminated.' + ELSE + NREC = 2 + WRITE (REC,'(A/A)') + &' ** The global error assessment algorithm failed at the start', + &' ** the integration. The integration is being terminated.' + END IF + GO TO 180 + END IF + END IF +C +C +C Exit point for CT +C + 180 CONTINUE +C +C Set the output variables and flag that interpolation is permitted +C + IF (IER.LT.911) THEN + TNOW = T + LAST = TNOW .EQ. TND + CHKEFF = LAST + DO 200 L = 1, NEQN + YNOW(L) = WORK(PRY-1+L) + YPNOW(L) = WORK(PRYP-1+L) + 200 CONTINUE + IF (IER.EQ.1) THEN + STATE = MINUS2 + CALL RKSIT(TELL,'INTRP',STATE) + END IF + END IF +C +C Call RKMSG to report what happened and set CFLAG. +C + CALL RKMSG(IER,SRNAME,NREC,CFLAG) +C + RETURN + END + SUBROUTINE INTRP(TWANT,REQEST,NWANT,YWANT,YPWANT,F,WORK,WRKINT, + & LENINT) +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C +C If you are not familiar with the code INTRP and how it is used in +C conjunction with CT to solve initial value problems, you should study the +C document file rksuite.doc carefully before attempting to use the code. The +C following "Brief Reminder" is intended only to remind you of the meaning, +C type, and size requirements of the arguments. +C +C When integrating with METHOD = 1 or 2, answers may be obtained inexpensively +C between steps by interpolation. INTRP is called after a step by CT from a +C previous value of T, called TOLD below, to the current value of T to get +C an answer at TWANT. You can specify any value of TWANT you wish, but +C specifying a value outside the interval [TOLD,T] is likely to yield +C answers with unsatisfactory accuracy. +C +C INPUT VARIABLE +C +C TWANT - DOUBLE PRECISION +C The value of the independent variable where a solution +C is desired. +C +C The interpolant is to be evaluated at TWANT to approximate the solution +C and/or its first derivative there. There are three cases: +C +C INPUT VARIABLE +C +C REQEST - CHARACTER*(*) +C Only the first character of REQEST is significant. +C REQEST(1:1) = `S' or `s'- compute approximate `S'olution +C only. +C = `D' or `d'- compute approximate first +C `D'erivative of the solution only. +C = `B' or `b'- compute `B'oth approximate solution +C and first derivative. +C Constraint: REQEST(1:1) must be `S',`s',`D',`d',`B' or `b'. +C +C If you intend to interpolate at many points, you should arrange for the +C the interesting components to be the first ones because the code +C approximates only the first NWANT components. +C +C INPUT VARIABLE +C +C NWANT - INTEGER +C Only the first NWANT components of the answer are to be +C computed. +C Constraint: NEQ >= NWANT >= 1 +C +C OUTPUT VARIABLES +C +C YWANT(*) - DOUBLE PRECISION array of length NWANT +C Approximation to the first NWANT components of the true +C solution at TWANT when REQESTed. +C YPWANT(*) - DOUBLE PRECISION array of length NWANT +C Approximation to the first NWANT components of the first +C derivative of the true solution at TWANT when REQESTed. +C +C NAME DECLARED IN AN EXTERNAL STATEMENT IN THE PROGRAM CALLING INTRP: +C +C F - name of the subroutine for evaluating the differential +C equations as provided to CT. +C +C WORKSPACE +C +C WORK(*) - DOUBLE PRECISION array as used in SETUP and CT +C Do not alter the contents of this array. +C +C WRKINT(*) - DOUBLE PRECISION array of length LENINT +C Do not alter the contents of this array. +C +C LENINT - INTEGER +C Length of WRKINT. If +C METHOD = 1, LENINT must be at least 1 +C = 2, LENINT must be at least NEQ+MAX(NEQ,5*NWANT) +C = 3--CANNOT BE USED WITH THIS SUBROUTINE +C +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C .. Scalar Arguments .. + DOUBLE PRECISION TWANT + INTEGER LENINT, NWANT + CHARACTER*(*) REQEST +C .. Array Arguments .. + DOUBLE PRECISION WORK(*), WRKINT(*), YPWANT(*), YWANT(*) +C .. Subroutine Arguments .. + EXTERNAL F +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block for General Workspace Pointers .. + INTEGER PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + COMMON /RKCOM3/ PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + SAVE /RKCOM3/ +C .. Common Block to hold Formula Definitions .. + DOUBLE PRECISION A(13,13), B(13), C(13), BHAT(13), R(11,6), + & E(7) + INTEGER PTR(13), NSTAGE, METHD, MINTP + LOGICAL INTP + COMMON /RKCOM4/ A, B, C, BHAT, R, E, PTR, NSTAGE, METHD, + & MINTP, INTP + SAVE /RKCOM4/ +C .. Common Block for Integrator Options .. + LOGICAL MSG, UTASK + COMMON /RKCOM8/ MSG, UTASK + SAVE /RKCOM8/ +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ +C .. Parameters .. + CHARACTER*6 SRNAME + PARAMETER (SRNAME='INTRP') + LOGICAL ASK + INTEGER PLUS1, MINUS1, MINUS2 + PARAMETER (ASK=.TRUE.,PLUS1=1,MINUS1=-1,MINUS2=-2) +C .. Local Scalars .. + INTEGER FLAG, ICHK, IER, NREC, NWNTSV, STARTP, STATE, + & STATE1 + LOGICAL ININTP, LEGALR + CHARACTER REQST1 +C .. External Subroutines .. + EXTERNAL EVALI, FORMI, RKMSG, RKSIT +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Save statement .. + SAVE NWNTSV, ININTP, STARTP +C .. Data statements .. + DATA NWNTSV/MINUS1/ +C .. Executable Statements .. +C + IER = 1 + NREC = 0 +C +C Is it permissible to call INTRP? +C + CALL RKSIT(ASK,'CT',STATE) + IF (STATE.EQ.911) THEN + IER = 912 + NREC = 1 + WRITE (REC,'(A)') + &' ** A catastrophic error has already been detected elsewhere.' + GO TO 20 + END IF + IF (UTASK) THEN + CALL RKSIT(ASK,'UT',STATE1) + IF (STATE1.NE.MINUS2) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A/A)') + &' ** You have called INTRP after you specified to SETUP ', + &' ** that you were going to use UT. This is not permitted.' + GO TO 20 + END IF + END IF + IF (STATE.EQ.MINUS1) THEN + IER = 911 + NREC = 1 + WRITE (REC,'(A)') + &' ** You have not called CT, so you cannot use INTRP.' + GO TO 20 + END IF + IF (STATE.GT.PLUS1) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A/A)') + &' ** CT has returned with a flag value greater than 1.', + &' ** You cannot call INTRP in this circumstance.' + GO TO 20 + END IF +C +C Check input +C + REQST1 = REQEST(1:1) + LEGALR = REQST1 .EQ. 'S' .OR. REQST1 .EQ. 's' .OR. + & REQST1 .EQ. 'D' .OR. REQST1 .EQ. 'd' .OR. + & REQST1 .EQ. 'B' .OR. REQST1 .EQ. 'b' + IF (.NOT.LEGALR) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A/A,A,A/A)') + &' ** You have set the first character of ', + &' ** REQEST to be ''',REQST1,'''. It must be one of ', + &' ** ''S'',''s'',''D'',''d'',''B'' or ''b''.' + GO TO 20 + END IF +C + IF (NWANT.GT.NEQN) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A,I6,A/A,I6,A/A)') + &' ** You have specified the value of NWANT to be ',NWANT,'. This', + &' ** is greater than ',NEQN,', which is the number of equations ', + &' ** in the system being integrated.' + GO TO 20 + ELSE IF (NWANT.LT.1) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A,I6,A/A/A)') + &' ** You have specified the value of NWANT to be ',NWANT,', but ', + &' ** this is less than 1. You cannot interpolate a zero or ', + &' ** negative number of components.' + GO TO 20 + END IF +C + IF (METHD.EQ.1) THEN + IF (LENINT.LT.1) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A,I6,A/A)') + &' ** You have specified LENINT to be ',LENINT,'.', + &' ** This is too small. LENINT must be at least 1.' + GO TO 20 + END IF + STARTP = 1 + ELSE IF (METHD.EQ.2) THEN + ICHK = NEQN + MAX(NEQN,5*NWANT) + IF (LENINT.LT.ICHK) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A,I6,A/A/A,I6,A)') + &' ** You have specified LENINT to be ',LENINT,'. This is too', + &' ** small. NINT must be at least NEQ + MAX(NEQ, 5*NWANT) ', + &' ** which is ', ICHK,'.' + GO TO 20 + END IF + STARTP = NEQN + 1 + ELSE IF (METHD.EQ.3) THEN + IER = 911 + NREC = 5 + WRITE (REC,'(A/A/A/A/A)') + &' ** You have been using CT with METHOD = 3 to integrate your ', + &' ** equations. You have just called INTRP, but interpolation ', + &' ** is not available for this METHOD. Either use METHOD = 2, ', + &' ** for which interpolation is available, or use RESET to make', + &' ** CT step exactly to the points where you want output.' + GO TO 20 + END IF +C +C Has the interpolant been initialised for this step? +C + CALL RKSIT(ASK,SRNAME,STATE) + ININTP = STATE .NE. MINUS2 +C +C Some initialization must be done before interpolation is possible. +C To reduce the overhead, the interpolating polynomial is formed for +C the first NWANT components. In the unusual circumstance that NWANT +C is changed while still interpolating within the span of the current +C step, the scheme must be reinitialized to accomodate the additional +C components. +C + IF (.NOT.ININTP .OR. NWANT.NE.NWNTSV) THEN +C +C At present the derivative of the solution at the previous step, YPOLD(*), +C is stored in the scratch array area starting at PRSCR. In the case of +C METHD = 1 we can overwrite the stages. +C + IF (METHD.EQ.1) THEN + CALL FORMI(F,NEQN,NWANT,WORK(PRY),WORK(PRYP),WORK(PRYOLD), + & WORK(PRSCR),WORK(PRSTGS),.NOT.ININTP, + & WORK(PRSTGS),WORK(PRSTGS)) + ELSE + CALL FORMI(F,NEQN,NWANT,WORK(PRY),WORK(PRYP),WORK(PRYOLD), + & WORK(PRSCR),WORK(PRSTGS),.NOT.ININTP,WRKINT, + & WRKINT(STARTP)) + END IF +C +C Set markers to show that interpolation has been initialized for +C NWANT components. + NWNTSV = NWANT + ININTP = .TRUE. + END IF +C +C The actual evaluation of the interpolating polynomial and/or its first +C derivative is done in EVALI. +C + IF (METHD.EQ.1) THEN + CALL EVALI(WORK(PRY),WORK(PRYP),WORK(PRSTGS),TWANT,REQEST, + & NWANT,YWANT,YPWANT) + ELSE + CALL EVALI(WORK(PRY),WORK(PRYP),WRKINT(STARTP),TWANT,REQEST, + & NWANT,YWANT,YPWANT) + END IF +C + 20 CONTINUE +C + CALL RKMSG(IER,SRNAME,NREC,FLAG) +C + RETURN + END + SUBROUTINE RESET(TENDNU) +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C +C If you are not familiar with the code RESET and how it is used in +C conjunction with CT to solve initial value problems, you should study the +C document file rksuite.doc carefully before attempting to use the code. The +C following "Brief Reminder" is intended only to remind you of the meaning, +C type, and size requirements of the arguments. +C +C The integration using CT proceeds from TSTART in the direction of TEND, and +C is now at TNOW. To reset TEND to a new value TENDNU, just call RESET with +C TENDNU as the argument. You must continue integrating in the same +C direction, so the sign of (TENDNU - TNOW) must be the same as the sign of +C (TEND - TSTART). To change direction you must restart by a call to SETUP. +C +C INPUT VARIABLE +C +C TENDNU - DOUBLE PRECISION +C The new value of TEND. +C Constraint: TENDNU and TNOW must be clearly distinguishable +C in the precision used. The sign of (TENDNU - TNOW) must be +C the same as the sign of (TEND - TSTART). +C +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C .. Scalar Arguments .. + DOUBLE PRECISION TENDNU +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Common Block for Integrator Options .. + LOGICAL MSG, UTASK + COMMON /RKCOM8/ MSG, UTASK + SAVE /RKCOM8/ +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ +C .. Parameters .. + CHARACTER*6 SRNAME + PARAMETER (SRNAME='RESET') + LOGICAL ASK + INTEGER MINUS1, MINUS2 + PARAMETER (ASK=.TRUE.,MINUS1=-1,MINUS2=-2) + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +C .. Local Scalars .. + DOUBLE PRECISION HMIN, TDIFF + INTEGER FLAG, IER, NREC, STATE, STATE1 +C .. External Subroutines .. + EXTERNAL RKMSG, RKSIT +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. Executable Statements .. + IER = 1 + NREC = 0 +C +C Is it permissible to call RESET? +C + CALL RKSIT(ASK,'CT',STATE) + IF (STATE.EQ.911) THEN + IER = 912 + NREC = 1 + WRITE (REC,'(A)') + &' ** A catastrophic error has already been detected elsewhere.' + GO TO 20 + END IF + IF (UTASK) THEN + CALL RKSIT(ASK,'UT',STATE1) + IF (STATE1.NE.MINUS2) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A/A)') + &' ** You have called RESET after you specified to SETUP that ', + &' ** you were going to use UT. This is not permitted.' + GO TO 20 + END IF + END IF + IF (STATE.EQ.MINUS1) THEN + IER = 911 + NREC = 1 + WRITE (REC,'(A)') + &' ** You have not called CT, so you cannot use RESET.' + GO TO 20 + END IF + IF (STATE.EQ.5 .OR. STATE.EQ.6) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A,I1,A/A)') + &' ** CT has returned with CFLAG = ',STATE,'.', + &' ** You cannot call RESET in this circumstance.' + GO TO 20 + END IF +C +C Check value of TENDNU +C + IF (DIR.GT.ZERO .AND. TENDNU.LE.T) THEN + IER = 911 + NREC = 4 + WRITE (REC,'(A/A,D13.5/A,D13.5,A/A)') + &' ** Integration is proceeding in the positive direction. The ', + &' ** current value for the independent variable is ',T, + &' ** and you have set TENDNU = ',TENDNU,'. TENDNU must be ', + &' ** greater than T.' + ELSE IF (DIR.LT.ZERO .AND. TENDNU.GE.T) THEN + IER = 911 + NREC = 4 + WRITE (REC,'(A/A,D13.5/A,D13.5,A/A)') + &' ** Integration is proceeding in the negative direction. The ', + &' ** current value for the independent variable is ',T, + &' ** and you have set TENDNU = ',TENDNU,'. TENDNU must be ', + &' ** less than T.' + ELSE + HMIN = MAX(TINY,TOOSML*MAX(ABS(T),ABS(TENDNU))) + TDIFF = ABS(TENDNU-T) + IF (TDIFF.LT.HMIN) THEN + IER = 911 + NREC = 4 + WRITE (REC,'(A,D13.5,A/A,D13.5,A/A/A,D13.5,A)') + &' ** The current value of the independent variable T is ',T,'.', + &' ** The TENDNU you supplied has ABS(TENDNU-T) = ',TDIFF,'.', + &' ** For the METHOD and the precision of the computer being ', + &' ** used, this difference must be at least ',HMIN,'.' + END IF + END IF + IF (IER.EQ.911) GO TO 20 +C + TND = TENDNU + LAST = .FALSE. +C + 20 CONTINUE +C + CALL RKMSG(IER,SRNAME,NREC,FLAG) +C + RETURN + END + SUBROUTINE MCONST(METHOD) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: Sets machine-dependent global quantities +C +C Common: Initializes: /RKCOM7/ OUTCH, MCHEPS, DWARF, RNDOFF, +C SQRRMC, CUBRMC, TINY +C Reads: none +C Alters: none +C +C Comments: +C ========= +C OUTCH, MCHEPS, DWARF are pure environmental parameters with values +C obtained from a call to ENVIRN. The other quantities set depend on +C the environmental parameters, the implementation, and, possibly, +C METHOD. At present the METHODs implemented in the RK suite do not +C influence the values of these quantities. +C OUTCH - Standard output channel +C MCHEPS - Largest positive number such that 1.0D0 + MCHEPS = 1.0D0 +C DWARF - Smallest positive number +C RNDOFF - 10 times MCHEPS +C SQRRMC - Square root of MCHEPS +C CUBRMC - Cube root of MCHEPS +C TINY - Square root of DWARF +C +C .. Scalar Arguments .. + INTEGER METHOD +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Parameters .. + DOUBLE PRECISION TEN, THIRD + PARAMETER (TEN=10.0D+0,THIRD=1.0D+0/3.0D+0) +C .. External Subroutines .. + EXTERNAL ENVIRN +C .. Intrinsic Functions .. + INTRINSIC SQRT +C .. Executable Statements .. +C + CALL ENVIRN(OUTCH,MCHEPS,DWARF) +C + RNDOFF = TEN*MCHEPS + SQRRMC = SQRT(MCHEPS) + CUBRMC = MCHEPS**THIRD + TINY = SQRT(DWARF) +C + RETURN + END + SUBROUTINE ENVIRN(OUTCH,MCHEPS,DWARF) +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C +C The RK suite requires some environmental parameters that are provided by +C this subroutine. The values provided with the distribution codes are those +C appropriate to the IEEE standard. They must be altered, if necessary, to +C those appropriate to the computing system you are using before calling the +C codes of the suite. +C +C ================================================================ +C ================================================================ +C TO MAKE SURE THAT THESE MACHINE AND INSTALLATION DEPENDENT +C QUANTITIES ARE SPECIFIED PROPERLY, THE DISTRIBUTION VERSION +C WRITES A MESSAGE ABOUT THE MATTER TO THE STANDARD OUTPUT CHANNEL +C AND TERMINATES THE RUN. THE VALUES PROVIDED IN THE DISTRIBUTION +C VERSION SHOULD BE ALTERED, IF NECESSARY, AND THE "WRITE" AND +C "STOP" STATEMENTS COMMENTED OUT. +C ================================================================ +C ================================================================ +C +C OUTPUT VARIABLES +C +C OUTCH - INTEGER +C Standard output channel +C MCHEPS - DOUBLE PRECISION +C MCHEPS is the largest positive number such that +C 1.0D0 + MCHEPS = 1.0D0. +C DWARF - DOUBLE PRECISION +C DWARF is the smallest positive number. +C +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C +C .. Scalar Arguments .. + INTEGER OUTCH + DOUBLE PRECISION DWARF, MCHEPS +C .. Executable Statements .. +C +C The following six statements are to be Commented out after verification that +C the machine and installation dependent quantities are specified correctly. +C If you pass copies of RKSUITE on to others, please give them the whole +C distribution version of RKSUITE, and in particular, give them a version +C of ENVIRN that does not have the following six statements Commented out. +C WRITE(*,*) ' Before using RKSUITE, you must verify that the ' +C WRITE(*,*) ' machine- and installation-dependent quantities ' +C WRITE(*,*) ' specified in the subroutine ENVIRN are correct, ' +C WRITE(*,*) ' and then Comment these WRITE statements and the ' +C WRITE(*,*) ' STOP statement out of ENVIRN. ' +C STOP +C +C The following values are appropriate to IEEE arithmetic with the typical +C standard output channel. +C + OUTCH = 6 + MCHEPS = 1.11D-16 + DWARF = 2.23D-308 +C +C------------------------------------------------------------------------------ +C If you have the routines D1MACH and I1MACH on your system, you could +C replace the preceding statements by the following ones to obtain the +C appropriate machine dependent numbers. The routines D1MACH and I1MACH +C are public domain software. They are available from NETLIB. +C .. Scalar Arguments .. +C INTEGER OUTCH +C DOUBLE PRECISION DWARF, MCHEPS +C .. External Functions .. +C INTEGER I1MACH +C DOUBLE PRECISION D1MACH +C .. Executable Statements .. +C +C OUTCH = I1MACH(2) +C MCHEPS = D1MACH(3) +C DWARF = D1MACH(1) +C +C If you have the NAG Fortran Library available on your system, you could +C replace the preceding statements by the following ones to obtain the +C appropriate machine dependent numbers. +C +C .. Scalar Arguments .. +C INTEGER OUTCH +C DOUBLE PRECISION DWARF, MCHEPS +C .. External Functions .. +C DOUBLE PRECISION X02AJF, X02AMF +C .. Executable Statements .. +C +C CALL X04AAF(0,OUTCH) +C MCHEPS = X02AJF() +C DWARF = X02AMF() +C +C If you have the IMSL MATH/LIBRARY available on your system, you could +C replace the preceding statements by the following ones to obtain the +C appropriate machine dependent numbers. +C +C .. Scalar Arguments .. +C INTEGER OUTCH +C DOUBLE PRECISION DWARF, MCHEPS +C .. External Functions .. +C DOUBLE PRECISION DMACH +C .. Executable Statements .. +C +C CALL UMACH(2,OUTCH) +C MCHEPS = DMACH(4) +C DWARF = DMACH(1) +C------------------------------------------------------------------------------ +C + RETURN + END + SUBROUTINE CONST(METHOD,VECSTG,REQSTG,LINTPL) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +************************************************* +C +C Purpose: Set formula definitions and formula characteristics for +C selected method. Return storage requirements for the +C selected method. +C +C Input: METHOD +C Output: VECSTG, REQSTG, LINTPL +C +C Common: Initializes: /RKCOM4/ A(*,*), B(*), C(*), BHAT(*), R(*), +C E(*), PTR(*), NSTAGE, METHD, INTP, MINTP +C /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, +C TANANG, RS, RS1, RS2, RS3, RS4, ORDER, +C LSTSTG, MAXTRY, NSEC, FSAL +C Reads: /RKCOM7/ RNDOFF +C Alters: none +C +C Comments: +C ========= +C Runge-Kutta formula pairs are described by a set of coefficients +C and by the setting of a number of parameters that describe the +C characteristics of the pair. The input variable METHD indicates +C which of the three pairs available is to be set. In the case of +C METHD = 2 additional coefficients are defined that make interpolation +C of the results possible and provide an additional error estimator. +C VECSTG is the number of columns of workspace required to compute the +C stages of a METHD. For interpolation purposes the routine returns via +C COMMON the logical variable INTP indicating whether interpolation is +C possible and via the call list: +C REQSTG - whether the stages are required to form the +C interpolant (set .FALSE. if INTP=.FALSE.) +C LINTPL - the number of extra columns of storage required for use +C with UT (set 0 if INTP=.FALSE.) +C +C Quantities set in common blocks: +C METHD - copy of METHOD +C A, B, C, BHAT - coefficients of the selected method +C R - extra coefficents for interpolation with METHD = 2 +C E - extra coefficients for additional local error estimate +C with METHD = 2 +C PTR - vector of pointers indicating how individual stages are to +C be stored. With it zero coefficients of the formulas can +C be exploited to reduce the storage required +C NSTAGE - number of stages for the specified METHD +C INTP - indicates whether there is an associated interpolant +C (depending on the method, the user may have to supply +C extra workspace) +C MINTP - the degree of the interpolating polynomial, if one exists +C FSAL - indicates whether the last stage of a step can be used as +C the first stage of the following step +C LSTSTG - pointer to location of last stage for use with FSAL=.TRUE. +C ORDER - the lower order of the pair of Runge-Kutta formulas that +C constitute a METHD +C TANANG, +C STBRAD - the stability region of the formula used to advance +C the integration is approximated by a sector in the left half +C complex plane. TANANG is the tangent of the interior angle +C of the sector and STBRAD is the radius of the sector. +C COST - cost of a successful step in function evaluations +C MAXTRY - limit on the number of iterations in the stiffness check. As +C set, no more than 24 function evaluations are made in the check. +C NSEC - each step of size H in the primary integration corresponds to +C NSEC steps of size H/NSEC in the secondary integration when +C global error assessment is done. +C EXPON - used to adjust the step size; this code implements an error +C per step control for which EXPON = 1/(ORDER + 1). +C SAFETY - quantity used in selecting the step size +C TOOSML - quantity used to determine when a step size is too small for +C the precision available +C RS, RS1, +C RS2, RS3, +C RS4 - quantities used in determining the maximum and minimum change +C change in step size (set independently of METHD) +C +C Further comments on SAFETY: +C ============================ +C The code estimates the largest step size that will yield the specified +C accuracy. About half the time this step size would result in a local +C error that is a little too large, and the step would be rejected. For +C this reason a SAFETY factor is used to reduce the "optimal" value to one +C more likely to succeed. Unfortunately, there is some art in choosing this +C value. The more expensive a failed step, the smaller one is inclined to +C take this factor. However, a small factor means that if the prediction were +C good, more accuracy than desired would be obtained and the behavior of the +C error would then be irregular. The more stringent the tolerance, the better +C the prediction, except near limiting precision. Thus the general range of +C tolerances expected influences the choice of SAFETY. +C +C .. Scalar Arguments .. + INTEGER LINTPL, METHOD, VECSTG + LOGICAL REQSTG +C .. Common Block to hold Formula Definitions .. + DOUBLE PRECISION A(13,13), B(13), C(13), BHAT(13), R(11,6), + & E(7) + INTEGER PTR(13), NSTAGE, METHD, MINTP + LOGICAL INTP + COMMON /RKCOM4/ A, B, C, BHAT, R, E, PTR, NSTAGE, METHD, + & MINTP, INTP + SAVE /RKCOM4/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO, TWO, FIFTY, FIVEPC + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0,TWO=2.0D+0,FIFTY=50.D+0, + & FIVEPC=0.05D+0) +C .. Local Scalars .. + DOUBLE PRECISION CDIFF, DIFF + INTEGER I, J +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN +C .. Executable Statements .. +C + METHD = METHOD +C + GO TO (20,40,100) METHD +C +C METHD = 1. +C This pair is from "A 3(2) Pair of Runge-Kutta Formulas" by P. Bogacki +C and L.F. Shampine, Appl. Math. Lett., 2, pp. 321-325, 1989. The authors +C are grateful to P. Bogacki for his assistance in implementing the pair. +C + 20 CONTINUE + NSTAGE = 4 + FSAL = .TRUE. + ORDER = 2 + TANANG = 8.9D0 + STBRAD = 2.3D0 + SAFETY = 0.8D0 + INTP = .TRUE. + MINTP = 3 + REQSTG = .FALSE. + LINTPL = 2 + NSEC = 3 +C + PTR(1) = 0 + PTR(2) = 1 + PTR(3) = 2 + PTR(4) = 3 +C + A(2,1) = 1.D0/2.D0 + A(3,1) = 0.D0 + A(3,2) = 3.D0/4.D0 + A(4,1) = 2.D0/9.D0 + A(4,2) = 1.D0/3.D0 + A(4,3) = 4.D0/9.D0 +C +C The coefficients BHAT(*) refer to the formula used to advance the +C integration, here the one of order 3. The coefficients B(*) refer +C to the other formula, here the one of order 2. For this pair, BHAT(*) +C is not needed since FSAL = .TRUE. +C + B(1) = 7.D0/24.D0 + B(2) = 1.D0/4.D0 + B(3) = 1.D0/3.D0 + B(4) = 1.D0/8.D0 +C + C(1) = 0.D0 + C(2) = 1.D0/2.D0 + C(3) = 3.D0/4.D0 + C(4) = 1.D0 +C + GO TO 120 +C +C METHD = 2 +C This pair is from "An Efficient Runge-Kutta (4,5) Pair" by P. Bogacki +C and L.F. Shampine, Rept. 89-20, Math. Dept., Southern Methodist +C University, Dallas, Texas, USA, 1989. The authors are grateful to +C P. Bogacki for his assistance in implementing the pair. Shampine and +C Bogacki subsequently modified the formula to enhance the reliability of +C the pair. The original fourth order formula is used in an estimate of +C the local error. If the step fails, the computation is broken off. If +C the step is acceptable, the first evaluation of the next step is done, +C i.e., the pair is implemented as FSAL and the local error of the step +C is again estimated with a fourth order formula using the additional data. +C The step must succeed with both estimators to be accepted. When the +C second estimate is formed, it is used for the subsequent adjustment of +C the step size because it is of higher quality. The two fourth order +C formulas are well matched to leading order, and only exceptionally do +C the estimators disagree -- problems with discontinuous coefficients are +C handled more reliably by using two estimators as is global error +C estimation. +C + 40 CONTINUE + NSTAGE = 8 + FSAL = .TRUE. + ORDER = 4 + TANANG = 5.2D0 + STBRAD = 3.9D0 + SAFETY = 0.8D0 + INTP = .TRUE. + REQSTG = .TRUE. + MINTP = 6 + LINTPL = 6 + NSEC = 2 +C + PTR(1) = 0 + PTR(2) = 1 + PTR(3) = 2 + PTR(4) = 3 + PTR(5) = 4 + PTR(6) = 5 + PTR(7) = 6 + PTR(8) = 7 +C + A(2,1) = 1.D0/6.D0 + A(3,1) = 2.D0/27.D0 + A(3,2) = 4.D0/27.D0 + A(4,1) = 183.D0/1372.D0 + A(4,2) = -162.D0/343.D0 + A(4,3) = 1053.D0/1372.D0 + A(5,1) = 68.D0/297.D0 + A(5,2) = -4.D0/11.D0 + A(5,3) = 42.D0/143.D0 + A(5,4) = 1960.D0/3861.D0 + A(6,1) = 597.D0/22528.D0 + A(6,2) = 81.D0/352.D0 + A(6,3) = 63099.D0/585728.D0 + A(6,4) = 58653.D0/366080.D0 + A(6,5) = 4617.D0/20480.D0 + A(7,1) = 174197.D0/959244.D0 + A(7,2) = -30942.D0/79937.D0 + A(7,3) = 8152137.D0/19744439.D0 + A(7,4) = 666106.D0/1039181.D0 + A(7,5) = -29421.D0/29068.D0 + A(7,6) = 482048.D0/414219.D0 + A(8,1) = 587.D0/8064.D0 + A(8,2) = 0.D0 + A(8,3) = 4440339.D0/15491840.D0 + A(8,4) = 24353.D0/124800.D0 + A(8,5) = 387.D0/44800.D0 + A(8,6) = 2152.D0/5985.D0 + A(8,7) = 7267.D0/94080.D0 +C +C The coefficients B(*) refer to the formula of order 4. +C + B(1) = 2479.D0/34992.D0 + B(2) = 0.D0 + B(3) = 123.D0/416.D0 + B(4) = 612941.D0/3411720.D0 + B(5) = 43.D0/1440.D0 + B(6) = 2272.D0/6561.D0 + B(7) = 79937.D0/1113912.D0 + B(8) = 3293.D0/556956.D0 +C +C The coefficients E(*) refer to an estimate of the local error based on +C the first formula of order 4. It is the difference of the fifth order +C result, here located in A(8,*), and the fourth order result. By +C construction both E(2) and E(7) are zero. +C + E(1) = -3.D0/1280.D0 + E(2) = 0.D0 + E(3) = 6561.D0/632320.D0 + E(4) = -343.D0/20800.D0 + E(5) = 243.D0/12800.D0 + E(6) = -1.D0/95.D0 + E(7) = 0.D0 +C + C(1) = 0.D0 + C(2) = 1.D0/6.D0 + C(3) = 2.D0/9.D0 + C(4) = 3.D0/7.D0 + C(5) = 2.D0/3.D0 + C(6) = 3.D0/4.D0 + C(7) = 1.D0 + C(8) = 1.D0 +C +C To do interpolation with this pair, some extra stages have to be computed. +C The following additional A(*,*) and C(*) coefficients are for this purpose. +C In addition there is an array R(*,*) that plays a role for interpolation +C analogous to that of BHAT(*) for the basic step. +C + C(9) = 1.D0/2.D0 + C(10) = 5.D0/6.D0 + C(11) = 1.D0/9.D0 +C + A(9,1) = 455.D0/6144.D0 + A(10,1) = -837888343715.D0/13176988637184.D0 + A(11,1) = 98719073263.D0/1551965184000.D0 + A(9,2) = 0.D0 + A(10,2) = 30409415.D0/52955362.D0 + A(11,2) = 1307.D0/123552.D0 + A(9,3) = 10256301.D0/35409920.D0 + A(10,3) = -48321525963.D0/759168069632.D0 + A(11,3) = 4632066559387.D0/70181753241600.D0 + A(9,4) = 2307361.D0/17971200.D0 + A(10,4) = 8530738453321.D0/197654829557760.D0 + A(11,4) = 7828594302389.D0/382182512025600.D0 + A(9,5) = -387.D0/102400.D0 + A(10,5) = 1361640523001.D0/1626788720640.D0 + A(11,5) = 40763687.D0/11070259200.D0 + A(9,6) = 73.D0/5130.D0 + A(10,6) = -13143060689.D0/38604458898.D0 + A(11,6) = 34872732407.D0/224610586200.D0 + A(9,7) = -7267.D0/215040.D0 + A(10,7) = 18700221969.D0/379584034816.D0 + A(11,7) = -2561897.D0/30105600.D0 + A(9,8) = 1.D0/32.D0 + A(10,8) = -5831595.D0/847285792.D0 + A(11,8) = 1.D0/10.D0 + A(10,9) = -5183640.D0/26477681.D0 + A(11,9) = -1.D0/10.D0 + A(11,10) = -1403317093.D0/11371610250.D0 +C + DO 60 I = 1, 11 + R(I,1) = 0.D0 + 60 CONTINUE + DO 80 I = 1, 6 + R(2,I) = 0.D0 + 80 CONTINUE + R(1,6) = -12134338393.D0/1050809760.D0 + R(1,5) = -1620741229.D0/50038560.D0 + R(1,4) = -2048058893.D0/59875200.D0 + R(1,3) = -87098480009.D0/5254048800.D0 + R(1,2) = -11513270273.D0/3502699200.D0 +C + R(3,6) = -33197340367.D0/1218433216.D0 + R(3,5) = -539868024987.D0/6092166080.D0 + R(3,4) = -39991188681.D0/374902528.D0 + R(3,3) = -69509738227.D0/1218433216.D0 + R(3,2) = -29327744613.D0/2436866432.D0 +C + R(4,6) = -284800997201.D0/19905339168.D0 + R(4,5) = -7896875450471.D0/165877826400.D0 + R(4,4) = -333945812879.D0/5671036800.D0 + R(4,3) = -16209923456237.D0/497633479200.D0 + R(4,2) = -2382590741699.D0/331755652800.D0 +C + R(5,6) = -540919.D0/741312.D0 + R(5,5) = -103626067.D0/43243200.D0 + R(5,4) = -633779.D0/211200.D0 + R(5,3) = -32406787.D0/18532800.D0 + R(5,2) = -36591193.D0/86486400.D0 +C + R(6,6) = 7157998304.D0/374350977.D0 + R(6,5) = 30405842464.D0/623918295.D0 + R(6,4) = 183022264.D0/5332635.D0 + R(6,3) = -3357024032.D0/1871754885.D0 + R(6,2) = -611586736.D0/89131185.D0 +C + R(7,6) = -138073.D0/9408.D0 + R(7,5) = -719433.D0/15680.D0 + R(7,4) = -1620541.D0/31360.D0 + R(7,3) = -385151.D0/15680.D0 + R(7,2) = -65403.D0/15680.D0 +C + R(8,6) = 1245.D0/64.D0 + R(8,5) = 3991.D0/64.D0 + R(8,4) = 4715.D0/64.D0 + R(8,3) = 2501.D0/64.D0 + R(8,2) = 149.D0/16.D0 + R(8,1) = 1.D0 +C + R(9,6) = 55.D0/3.D0 + R(9,5) = 71.D0 + R(9,4) = 103.D0 + R(9,3) = 199.D0/3.D0 + R(9,2) = 16.0D0 +C + R(10,6) = -1774004627.D0/75810735.D0 + R(10,5) = -1774004627.D0/25270245.D0 + R(10,4) = -26477681.D0/359975.D0 + R(10,3) = -11411880511.D0/379053675.D0 + R(10,2) = -423642896.D0/126351225.D0 +C + R(11,6) = 35.D0 + R(11,5) = 105.D0 + R(11,4) = 117.D0 + R(11,3) = 59.D0 + R(11,2) = 12.D0 +C + GO TO 120 +C +C METHD = 3 +C This pair is from "High Order Embedded Runge-Kutta Formulae" by P.J. +C Prince and J.R. Dormand, J. Comp. Appl. Math.,7, pp. 67-75, 1981. The +C authors are grateful to P. Prince and J. Dormand for their assistance in +C implementing the pair. +C + 100 CONTINUE + NSTAGE = 13 + FSAL = .FALSE. + ORDER = 7 + TANANG = 11.0D0 + STBRAD = 5.2D0 + SAFETY = 0.8D0 + INTP = .FALSE. + REQSTG = .FALSE. + MINTP = 0 + LINTPL = 0 + NSEC = 2 +C + PTR(1) = 0 + PTR(2) = 1 + PTR(3) = 2 + PTR(4) = 1 + PTR(5) = 3 + PTR(6) = 2 + PTR(7) = 4 + PTR(8) = 5 + PTR(9) = 6 + PTR(10) = 7 + PTR(11) = 8 + PTR(12) = 9 + PTR(13) = 1 +C + A(2,1) = 5.55555555555555555555555555556D-2 + A(3,1) = 2.08333333333333333333333333333D-2 + A(3,2) = 6.25D-2 + A(4,1) = 3.125D-2 + A(4,2) = 0.D0 + A(4,3) = 9.375D-2 + A(5,1) = 3.125D-1 + A(5,2) = 0.D0 + A(5,3) = -1.171875D0 + A(5,4) = 1.171875D0 + A(6,1) = 3.75D-2 + A(6,2) = 0.D0 + A(6,3) = 0.D0 + A(6,4) = 1.875D-1 + A(6,5) = 1.5D-1 + A(7,1) = 4.79101371111111111111111111111D-2 + A(7,2) = 0.D0 + A(7,3) = 0.0D0 + A(7,4) = 1.12248712777777777777777777778D-1 + A(7,5) = -2.55056737777777777777777777778D-2 + A(7,6) = 1.28468238888888888888888888889D-2 + A(8,1) = 1.6917989787292281181431107136D-2 + A(8,2) = 0.D0 + A(8,3) = 0.D0 + A(8,4) = 3.87848278486043169526545744159D-1 + A(8,5) = 3.59773698515003278967008896348D-2 + A(8,6) = 1.96970214215666060156715256072D-1 + A(8,7) = -1.72713852340501838761392997002D-1 + A(9,1) = 6.90957533591923006485645489846D-2 + A(9,2) = 0.D0 + A(9,3) = 0.D0 + A(9,4) = -6.34247976728854151882807874972D-1 + A(9,5) = -1.61197575224604080366876923982D-1 + A(9,6) = 1.38650309458825255419866950133D-1 + A(9,7) = 9.4092861403575626972423968413D-1 + A(9,8) = 2.11636326481943981855372117132D-1 + A(10,1) = 1.83556996839045385489806023537D-1 + A(10,2) = 0.D0 + A(10,3) = 0.D0 + A(10,4) = -2.46876808431559245274431575997D0 + A(10,5) = -2.91286887816300456388002572804D-1 + A(10,6) = -2.6473020233117375688439799466D-2 + A(10,7) = 2.84783876419280044916451825422D0 + A(10,8) = 2.81387331469849792539403641827D-1 + A(10,9) = 1.23744899863314657627030212664D-1 + A(11,1) = -1.21542481739588805916051052503D0 + A(11,2) = 0.D0 + A(11,3) = 0.D0 + A(11,4) = 1.66726086659457724322804132886D1 + A(11,5) = 9.15741828416817960595718650451D-1 + A(11,6) = -6.05660580435747094755450554309D0 + A(11,7) = -1.60035735941561781118417064101D1 + A(11,8) = 1.4849303086297662557545391898D1 + A(11,9) = -1.33715757352898493182930413962D1 + A(11,10) = 5.13418264817963793317325361166D0 + A(12,1) = 2.58860916438264283815730932232D-1 + A(12,2) = 0.D0 + A(12,3) = 0.D0 + A(12,4) = -4.77448578548920511231011750971D0 + A(12,5) = -4.3509301377703250944070041181D-1 + A(12,6) = -3.04948333207224150956051286631D0 + A(12,7) = 5.57792003993609911742367663447D0 + A(12,8) = 6.15583158986104009733868912669D0 + A(12,9) = -5.06210458673693837007740643391D0 + A(12,10) = 2.19392617318067906127491429047D0 + A(12,11) = 1.34627998659334941535726237887D-1 + A(13,1) = 8.22427599626507477963168204773D-1 + A(13,2) = 0.D0 + A(13,3) = 0.D0 + A(13,4) = -1.16586732572776642839765530355D1 + A(13,5) = -7.57622116690936195881116154088D-1 + A(13,6) = 7.13973588159581527978269282765D-1 + A(13,7) = 1.20757749868900567395661704486D1 + A(13,8) = -2.12765911392040265639082085897D0 + A(13,9) = 1.99016620704895541832807169835D0 + A(13,10) = -2.34286471544040292660294691857D-1 + A(13,11) = 1.7589857770794226507310510589D-1 + A(13,12) = 0.D0 +C +C The coefficients BHAT(*) refer to the formula used to advance the +C integration, here the one of order 8. The coefficients B(*) refer +C to the other formula, here the one of order 7. +C + BHAT(1) = 4.17474911415302462220859284685D-2 + BHAT(2) = 0.D0 + BHAT(3) = 0.D0 + BHAT(4) = 0.D0 + BHAT(5) = 0.D0 + BHAT(6) = -5.54523286112393089615218946547D-2 + BHAT(7) = 2.39312807201180097046747354249D-1 + BHAT(8) = 7.0351066940344302305804641089D-1 + BHAT(9) = -7.59759613814460929884487677085D-1 + BHAT(10) = 6.60563030922286341461378594838D-1 + BHAT(11) = 1.58187482510123335529614838601D-1 + BHAT(12) = -2.38109538752862804471863555306D-1 + BHAT(13) = 2.5D-1 +C + B(1) = 2.9553213676353496981964883112D-2 + B(2) = 0.D0 + B(3) = 0.D0 + B(4) = 0.D0 + B(5) = 0.D0 + B(6) = -8.28606276487797039766805612689D-1 + B(7) = 3.11240900051118327929913751627D-1 + B(8) = 2.46734519059988698196468570407D0 + B(9) = -2.54694165184190873912738007542D0 + B(10) = 1.44354858367677524030187495069D0 + B(11) = 7.94155958811272872713019541622D-2 + B(12) = 4.44444444444444444444444444445D-2 + B(13) = 0.D0 +C + C(1) = 0.D0 + C(2) = 5.55555555555555555555555555556D-2 + C(3) = 8.33333333333333333333333333334D-2 + C(4) = 1.25D-1 + C(5) = 3.125D-1 + C(6) = 3.75D-1 + C(7) = 1.475D-1 + C(8) = 4.65D-1 + C(9) = 5.64865451382259575398358501426D-1 + C(10) = 6.5D-1 + C(11) = 9.24656277640504446745013574318D-1 + C(12) = 1.D0 + C(13) = C(12) +C + GO TO 120 +C +C The definitions of all pairs come here for the calculation of +C LSTSTG, RS1, RS2, RS3, RS4, COST, MAXTRY, EXPON, TOOSML, and VECSTG. +C + 120 CONTINUE + LSTSTG = PTR(NSTAGE) + IF (FSAL) THEN + COST = DBLE(NSTAGE-1) + ELSE + COST = DBLE(NSTAGE) + END IF +C +C MAXTRY - limit on the number of iterations of a computation made in +C diagnosing stiffness. There are at most Q = 3 function calls per +C iteration. MAXTRY is determined so that Q*MAXTRY <= 5% of the cost of +C 50 steps and 1 <= MAXTRY <= 8. This limits the number of calls to FCN +C in each diagnosis of stiffness to 24 calls. +C + MAXTRY = MIN(8,MAX(1,INT(FIVEPC*COST*FIFTY))) +C + EXPON = ONE/(ORDER+ONE) +C +C In calculating CDIFF it is assumed that there will be a non-zero +C difference |C(I) - C(J)| less than one. If C(I) = C(J) for any I not +C equal to J, they should be made precisely equal by assignment. +C + CDIFF = ONE + DO 160 I = 1, NSTAGE - 1 + DO 140 J = I + 1, NSTAGE + DIFF = ABS(C(I)-C(J)) + IF (DIFF.NE.ZERO) CDIFF = MIN(CDIFF,DIFF) + 140 CONTINUE + 160 CONTINUE + TOOSML = RNDOFF/CDIFF +C +C Determine the number of columns needed in STAGES(1:NEQ,*) (this will be +C at most NSTAGE-1 since the first stage is held in a separate array). +C The PTR array contains the column positions of the stages. +C + VECSTG = 0 + DO 180 I = 2, NSTAGE + VECSTG = MAX(PTR(I),VECSTG) + 180 CONTINUE +C + RS = TWO + RS1 = ONE/RS + RS2 = RS**2 + RS3 = RS**3 + RS4 = ONE/RS3 +C + RETURN + END + SUBROUTINE FORMI(F,NEQ,NWANT,Y,YP,YOLD,YPOLD,STAGES,CALSTG, + & XSTAGE,P) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: Forms an interpolating polynomial for use with +C METHDs 1 or 2. +C +C Input: NEQ, NWANT, T, Y(*), YP(*), HOLD, YOLD(*), YPOLD(*), +C STAGES(NEQ,*), CALSTG +C Output: P(*), XSTAGE(NEQ) +C External: F +C +C Common: Initializes: none +C Reads: /RKCOM4/ A(*,*), C(*), R(*), METHD, MINTP +C /RKCOM2/ T, TOLD, HOLD +C Alters: /RKCOM2/ NFCN +C +C Comments: +C ========= +C The integration has reached T with a step HOLD from TOLD = T-HOLD. +C Y(*),YP(*) and YOLD(*),YPOLD(*) approximate the solution and its +C derivative at T and TOLD respectively. STAGES(NEQ,*) holds the stages +C computed in taking this step. In the case of METHD = 2 it is necessary +C to compute some more stages in this subroutine. CALSTG indicates whether +C or not the extra stages need to be computed. A(*,*) and C(*) are used in +C computing these stages. The extra stages are stored in STAGES(NEQ,*) and +C XSTAGE(*). The coefficients of the interpolating polynomials for the first +C NWANT components of the solution are returned in the array P(*). The +C polynomial is of degree MINTP = 3 for METHD = 1 and of degree MINTP = 6 +C for METHD = 2. The vector R(*) is used for workspace when METHD = 2. +C +C .. Scalar Arguments .. + INTEGER NEQ, NWANT + LOGICAL CALSTG +C .. Array Arguments .. + DOUBLE PRECISION P(*), STAGES(NEQ,*), XSTAGE(*), Y(*), YOLD(*), + & YP(*), YPOLD(*) +C .. Subroutine Arguments .. + EXTERNAL F +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block to hold Formula Definitions .. + DOUBLE PRECISION A(13,13), B(13), C(13), BHAT(13), R(11,6), + & E(7) + INTEGER PTR(13), NSTAGE, METHD, MINTP + LOGICAL INTP + COMMON /RKCOM4/ A, B, C, BHAT, R, E, PTR, NSTAGE, METHD, + & MINTP, INTP + SAVE /RKCOM4/ +C .. Local Scalars .. + DOUBLE PRECISION D1, D2, D3, D4, HYP, HYPOLD + INTEGER I, J, K, L +C .. Executable Statements .. +C + IF (METHD.EQ.1) THEN +C +C METHD = 1. Use the cubic Hermite interpolant that is is fully +C specified by the values and slopes at the two ends of the step. +C + DO 20 L = 1, NWANT + D1 = Y(L) - YOLD(L) + HYP = HOLD*YP(L) + HYPOLD = HOLD*YPOLD(L) + D2 = HYP - D1 + D3 = D1 - HYPOLD + D4 = D2 - D3 + P(L) = D2 + D4 + P(NWANT+L) = D4 + 20 CONTINUE +C + ELSE +C +C METHD = 2. +C + IF (CALSTG) THEN +C +C Compute the extra stages needed for interpolation using the facts that +C 1. Stage 1 is YPOLD(*). +C 2. Stage i (i>1) is stored in STAGES(1:NEQ,i). +C 3. This pair is FSAL, i.e. STAGES(1:NEQ,7)=YP(1:NEQ), which frees +C up STAGES(1:NEQ,7) for use by stage 9. +C 4. XSTAGE(1:NEQ) is used for stage 10. +C 5. The coefficient of stage 2 in the interpolant is always 0, so +C STAGES(1:NEQ,1) is used for stage 11. +C The vector P(1:NEQ) is used as workspace for computing the stages. +C + DO 180 I = 9, 11 + DO 40 L = 1, NEQ + P(L) = A(I,1)*YPOLD(L) + 40 CONTINUE + DO 140 J = 2, I - 1 + IF (J.LE.7) THEN + DO 60 L = 1, NEQ + P(L) = P(L) + A(I,J)*STAGES(L,J-1) + 60 CONTINUE + ELSE IF (J.EQ.8) THEN + DO 80 L = 1, NEQ + P(L) = P(L) + A(I,J)*YP(L) + 80 CONTINUE + ELSE IF (J.EQ.9) THEN + DO 100 L = 1, NEQ + P(L) = P(L) + A(I,J)*STAGES(L,7) + 100 CONTINUE + ELSE IF (J.EQ.10) THEN + DO 120 L = 1, NEQ + P(L) = P(L) + A(I,J)*XSTAGE(L) + 120 CONTINUE + END IF + 140 CONTINUE + DO 160 L = 1, NEQ + P(L) = YOLD(L) + HOLD*P(L) + 160 CONTINUE + IF (I.EQ.9) THEN + CALL F(TOLD+C(I)*HOLD,P,STAGES(1,7)) + NFCN = NFCN + 1 + ELSE IF (I.EQ.10) THEN + CALL F(TOLD+C(I)*HOLD,P,XSTAGE) + NFCN = NFCN + 1 + ELSE + CALL F(TOLD+C(I)*HOLD,P,STAGES(1,1)) + NFCN = NFCN + 1 + END IF + 180 CONTINUE + END IF +C +C Form the coefficients of the interpolating polynomial in its shifted +C and scaled form. The transformation from the form in which the +C polynomial is derived can be somewhat ill-conditioned. The terms +C are grouped so as to minimize the errors of the transformation. +C +C Coefficient of SIGMA**6 + K = 4*NWANT + DO 200 L = 1, NWANT + P(K+L) = R(5,6)*STAGES(L,4) + + & ((R(10,6)*XSTAGE(L)+R(8,6)*YP(L))+ + & (R(7,6)*STAGES(L,6)+R(6,6)*STAGES(L,5))) + + & ((R(4,6)*STAGES(L,3)+R(9,6)*STAGES(L,7))+ + & (R(3,6)*STAGES(L,2)+R(11,6)*STAGES(L,1))+ + & R(1,6)*YPOLD(L)) + 200 CONTINUE +C +C Coefficient of SIGMA**5 + K = 3*NWANT + DO 220 L = 1, NWANT + P(K+L) = (R(10,5)*XSTAGE(L)+R(9,5)*STAGES(L,7)) + + & ((R(7,5)*STAGES(L,6)+R(6,5)*STAGES(L,5))+ + & R(5,5)*STAGES(L,4)) + ((R(4,5)*STAGES(L,3)+ + & R(8,5)*YP(L))+(R(3,5)*STAGES(L,2)+R(11,5)* + & STAGES(L,1))+R(1,5)*YPOLD(L)) + 220 CONTINUE +C +C Coefficient of SIGMA**4 + K = 2*NWANT + DO 240 L = 1, NWANT + P(K+L) = ((R(4,4)*STAGES(L,3)+R(8,4)*YP(L))+ + & (R(7,4)*STAGES(L,6)+R(6,4)*STAGES(L,5))+ + & R(5,4)*STAGES(L,4)) + ((R(10,4)*XSTAGE(L)+ + & R(9,4)*STAGES(L,7))+(R(3,4)*STAGES(L,2)+ + & R(11,4)*STAGES(L,1))+R(1,4)*YPOLD(L)) + 240 CONTINUE +C +C Coefficient of SIGMA**3 + K = NWANT + DO 260 L = 1, NWANT + P(K+L) = R(5,3)*STAGES(L,4) + R(6,3)*STAGES(L,5) + + & ((R(3,3)*STAGES(L,2)+R(9,3)*STAGES(L,7))+ + & (R(10,3)*XSTAGE(L)+R(8,3)*YP(L))+R(1,3)* + & YPOLD(L))+((R(4,3)*STAGES(L,3)+R(11,3)* + & STAGES(L,1))+R(7,3)*STAGES(L,6)) + 260 CONTINUE +C +C Coefficient of SIGMA**2 +C + DO 280 L = 1, NWANT + P(L) = R(5,2)*STAGES(L,4) + ((R(6,2)*STAGES(L,5)+ + & R(8,2)*YP(L))+R(1,2)*YPOLD(L)) + + & ((R(3,2)*STAGES(L,2)+R(9,2)*STAGES(L,7))+ + & R(10,2)*XSTAGE(L)) + ((R(4,2)*STAGES(L,3)+ + & R(11,2)*STAGES(L,1))+R(7,2)*STAGES(L,6)) + 280 CONTINUE +C +C Scale all the coefficients by the step size. +C + DO 300 L = 1, NWANT*(MINTP-1) + P(L) = HOLD*P(L) + 300 CONTINUE +C + END IF +C + RETURN + END + SUBROUTINE EVALI(Y,YP,P,TWANT,REQEST,NWANT,YWANT,YPWANT) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +************************************************* +C +C Purpose: Evaluation of an interpolating polynomial and/or its +C first derivative. +C +C Input: Y(*), YP(*), P(NWANT,*), TWANT, REQEST, NWANT +C Output: YWANT(*), YPWANT(*) +C +C Common: Initializes: none +C Reads: /RKCOM2/ HOLD, T +C /RKCOM4/ MINTP +C Alters: none +C +C Comments: +C ========= +C The interpolant is evaluated at TWANT to approximate the solution, +C YWANT, and/or its first derivative there, YPWANT. Only the first +C NWANT components of the answer are computed. There are three cases +C that are indicated by the first character of REQEST: +C REQEST(1:1) = `S' or `s'- compute approximate `S'olution only. +C = `D' or `d'- compute approximate first `D'erivative +C of the solution only. +C = `B' or `b'- compute `B'oth approximate solution and +C first derivative. +C The coefficents of the polynomial are contained in Y(*), YP(*) and +C P(NWANT,*). +C +C .. Scalar Arguments .. + DOUBLE PRECISION TWANT + INTEGER NWANT + CHARACTER*(*) REQEST +C .. Array Arguments .. + DOUBLE PRECISION P(NWANT,*), Y(*), YP(*), YPWANT(*), YWANT(*) +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block to hold Formula Definitions .. + DOUBLE PRECISION A(13,13), B(13), C(13), BHAT(13), R(11,6), + & E(7) + INTEGER PTR(13), NSTAGE, METHD, MINTP + LOGICAL INTP + COMMON /RKCOM4/ A, B, C, BHAT, R, E, PTR, NSTAGE, METHD, + & MINTP, INTP + SAVE /RKCOM4/ +C .. Local Scalars .. + DOUBLE PRECISION SIGMA + INTEGER K, L + CHARACTER REQST1 +C .. Executable Statements .. +C +C Evaluate the interpolating polynomial of degree MINTP in terms of the +C shifted and scaled independent variable SIGMA. +C + SIGMA = (TWANT-T)/HOLD +C + REQST1 = REQEST(1:1) + IF (REQST1.EQ.'S' .OR. REQST1.EQ.'s' .OR. + & REQST1.EQ.'B' .OR. REQST1.EQ.'b') THEN +C + DO 20 L = 1, NWANT + YWANT(L) = P(L,MINTP-1)*SIGMA + 20 CONTINUE + DO 60 K = MINTP - 2, 1, -1 + DO 40 L = 1, NWANT + YWANT(L) = (YWANT(L)+P(L,K))*SIGMA + 40 CONTINUE + 60 CONTINUE + DO 80 L = 1, NWANT + YWANT(L) = (YWANT(L)+HOLD*YP(L))*SIGMA + Y(L) + 80 CONTINUE + END IF +C +C Evaluate the derivative of the interpolating polynomial. +C + IF (REQST1.EQ.'D' .OR. REQST1.EQ.'d' .OR. + & REQST1.EQ.'B' .OR. REQST1.EQ.'b') THEN +C +C The derivative of the interpolating polynomial with respect to TWANT +C is the derivative with respect to S divided by HOLD. +C + DO 100 L = 1, NWANT + YPWANT(L) = MINTP*P(L,MINTP-1)*SIGMA + 100 CONTINUE + DO 140 K = MINTP - 1, 2, -1 + DO 120 L = 1, NWANT + YPWANT(L) = (YPWANT(L)+K*P(L,K-1))*SIGMA + 120 CONTINUE + 140 CONTINUE + DO 160 L = 1, NWANT + YPWANT(L) = (YPWANT(L)+HOLD*YP(L))/HOLD + 160 CONTINUE + END IF +C + RETURN + END + SUBROUTINE RKMSG(IER,SRNAME,NREC,FLAG) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: To process error messages and terminate the program +C in the event of a "catastrophic" failure. +C +C Input: IER, SRNAME, NREC +C Output: FLAG +C +C Common: Initializes: none +C Reads: /RKCOM7/ OUTCH +C /RKCOM8/ MSG, UTASK +C /RKCOM9/ REC +C Alters: none +C +C Comments: +C ========= +C The output variable FLAG is assigned the value of the input variable IER. +C +C IER = -2 reports a successful call of the subroutine SRNAME and +C indicates that special action is to be taken elsewhere +C in the suite. FLAG is set and a return is effected. +C +C IER = 1 reports a successful call of the subroutine SRNAME. FLAG +C is set and a return is effected. +C +C 1 < IER < 911 and MSG = .TRUE.: a message of NREC records contained in +C the array REC(*) is written to the standard output channel, +C OUTCH. FLAG is set and a return is effected. +C +C IER = 911 reports a "catastrophic" error was detected in SRNAME. A +C message is written to OUTCH regardless of the value of MSG and +C normally the execution of the program is terminated. The +C execution is not terminated if the error is the result of an +C indirect call to CT, RESET, or INTRP through UT (UTASK = .TRUE.). +C Termination can be prevented by using the subroutine SOFTFL. +C +C IER = 912 reports that a "catastrophic" error was detected earlier and +C termination was prevented, but the user has failed to take +C appropriate remedial action. Execution is terminated. +C +C .. Scalar Arguments .. + INTEGER FLAG, IER, NREC + CHARACTER*(*) SRNAME +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Common Block for Integrator Options .. + LOGICAL MSG, UTASK + COMMON /RKCOM8/ MSG, UTASK + SAVE /RKCOM8/ +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ +C .. Parameters .. + INTEGER PLUS1 + LOGICAL ASK, TELL + PARAMETER (PLUS1=1,ASK=.TRUE.,TELL=.FALSE.) +C .. Local Scalars .. + INTEGER I + LOGICAL BADERR, OK, ON, UTCALL +C .. External Subroutines .. + EXTERNAL CHKFL, RKSIT, SOFTFL +C .. Executable Statements .. +C +C Check where the call came from - if it is an indirect call from UT, +C the run is not STOPped. + UTCALL = (SRNAME.EQ.'RESET' .OR. SRNAME.EQ.'CT' .OR. + & SRNAME.EQ.'INTRP') .AND. UTASK +C +C Check if can continue with integrator. + OK = (SRNAME.EQ.'CT' .OR. SRNAME.EQ.'UT') .AND. + & (IER.EQ.2 .OR. IER.EQ.3 .OR. IER.EQ.4) +C +C Check if program termination has been overridden. + CALL SOFTFL(ASK,ON) +C + IF ((MSG.AND.IER.GT.PLUS1) .OR. IER.GE.911) THEN + WRITE (OUTCH,'(/A)') ' **' + WRITE (OUTCH,'(A)') (REC(I),I=1,NREC) + IF (IER.GE.911) THEN + WRITE (OUTCH,'(A/A,A,A/A/)') + &' **', + &' ** Catastrophic error detected in ', SRNAME, '.', + &' **' + IF ((.NOT.(UTCALL.OR.ON).AND.IER.EQ.911) .OR. + & IER.EQ.912) THEN + WRITE (OUTCH,'(A/A/A)') + &' **', + &' ** Execution of your program is being terminated.', + &' **' + STOP + END IF + ELSE IF (OK) THEN + WRITE (OUTCH,'(A/A,A,A,I2,A/A/A)') + &' **', + &' ** Warning from routine ', SRNAME, ' with flag set ',IER, '.', + &' ** You can continue integrating this problem.', + &' **' + ELSE + WRITE (OUTCH,'(A/A,A,A,I2,A/A/A)') + &' **', + &' ** Warning from routine ', SRNAME, ' with flag set ',IER, '.', + &' ** You cannot continue integrating this problem.', + &' **' + END IF + END IF + DO 20 I = NREC + 1, 10 + REC(I) = ' ' + 20 CONTINUE + FLAG = IER +C +C TELL RKSIT the status of the routine associated with SRNAME + CALL RKSIT(TELL,SRNAME,FLAG) +C +C Indicate that a catastrophic error has been detected + BADERR = FLAG .GE. 911 + CALL CHKFL(TELL,BADERR) +C + RETURN +C + END + SUBROUTINE RKSIT(ASK,SRNAME,STATE) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: To save or enquire about the status of each +C subprogram in the suite. +C +C Input: ASK, SRNAME +C Input/output: STATE +C +C +C Comments: +C ========= +C SRNAME indicates which routine is of interest in the call to RKSIT. +C +C If ASK=.FALSE., then the value of STATE (which as used is the error +C flag) for the routine SRNAME is saved internally. This value of STATE +C is usually positive. There are two exceptions: +C 1. SRNAME='SETUP' and STATE=-1 indicates a completely new problem, +C so all SAVEd states are cleared. +C 2. STATE=-2 is used by some routines in the suite to indicate +C circumstances which require special action. +C +C If ASK=.TRUE., then RKSIT first checks to see if there were any +C catastrophic errors, that is, a SAVEd state has value 911. This should +C happen only when the user has overridden program termination in the event +C of catastrophic failures from routines in the package but has failed to +C take appropriate action. If this is the case, then RKSIT returns a value +C of STATE = 911 which forces a termination of execution inside RKMSG. If +C no catastrophic errors are flagged, then STATE returns the saved state +C value for the routine specified by SRNAME. +C +C .. Scalar Arguments .. + INTEGER STATE + LOGICAL ASK + CHARACTER*(*) SRNAME +C .. Parameters .. + INTEGER STATES, MINUS1 + PARAMETER (STATES=7,MINUS1=-1) +C .. Local Scalars .. + INTEGER I, NAME +C .. Local Arrays .. + INTEGER SVSTA(STATES) +C .. Save statement .. + SAVE SVSTA +C .. Data statements .. + DATA SVSTA/STATES*MINUS1/ +C .. Executable Statements .. +C + IF (SRNAME.EQ.'SETUP') THEN + NAME = 1 + ELSE IF (SRNAME.EQ.'UT') THEN + NAME = 2 + ELSE IF (SRNAME.EQ.'STAT') THEN + NAME = 3 + ELSE IF (SRNAME.EQ.'GLBERR') THEN + NAME = 4 + ELSE IF (SRNAME.EQ.'CT') THEN + NAME = 5 + ELSE IF (SRNAME.EQ.'INTRP') THEN + NAME = 6 + ELSE IF (SRNAME.EQ.'RESET') THEN + NAME = 7 + ELSE + NAME = 0 + END IF +C +C (Re)initialize if SETUP is telling RKSIT to do so. + IF (.NOT.ASK .AND. NAME.EQ.1 .AND. STATE.EQ.MINUS1) THEN + DO 20 I = 1, STATES + SVSTA(I) = MINUS1 + 20 CONTINUE + GO TO 60 + END IF +C +C Check for 911 on exit from a previous call. + IF (ASK) THEN + DO 40 I = 1, STATES + IF (SVSTA(I).EQ.911) THEN + STATE = 911 + GO TO 60 + END IF + 40 CONTINUE + END IF +C + IF (ASK) THEN + STATE = SVSTA(NAME) + ELSE + SVSTA(NAME) = STATE + END IF +C + 60 CONTINUE +C + RETURN + END + SUBROUTINE TRUERR(F,NEQ,Y,TOL,WEIGHT,ZY,ZYP,ZERROR,ZYNEW,ZERRES, + & ZSTAGE,IER) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: Compute a running RMS measure of the true (global) error +C for a general Runge-Kutta pair. +C +C +C Input: NEQ, Y(*), TOL, WEIGHT(*), +C Input/output: ZY(*), ZYP(*), ZERROR(*) +C Workspace: ZYNEW(*), ZERRES(*), ZSTAGE(NEQ,*) +C Output: IER +C External: F +C +C Common: Initializes: none +C Reads: /RKCOM2/ T, HOLD +C /RKCOM5/ TOOSML, ORDER, NSEC +C /RKCOM7/ TINY +C Alters: /RKCOM6/ MAXERR, LOCMAX, GNFCN +C +C Comments: +C ========= +C A secondary integration is performed using a fraction of the step size +C of the primary integration. ZY(*) and ZYP(*) are the approximate solution +C and first derivative of this secondary integration. ZERRES(*) contains the +C error estimates for the secondary integration. ZYNEW(*) and ZSTAGE(*,*) are +C workspace for taking a step. The error assessment is computed using the +C difference of the primary and secondary solutions at the primary +C integration points as an estimate of the true error there. The weights +C used are those of the error test of the primary integration. This error +C assessment is maintained in the vector ZERROR(*). MAXERR and LOCMAX +C contain the maximum contribution to the assessment and its location, +C respectively. The number of calls to F is counted by GNFCN. +C +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER IER, NEQ +C .. Array Arguments .. + DOUBLE PRECISION WEIGHT(*), Y(*), ZERRES(*), ZERROR(*), + & ZSTAGE(NEQ,*), ZY(*), ZYNEW(*), ZYP(*) +C .. Subroutine Arguments .. + EXTERNAL F +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Global Error Assessment .. + DOUBLE PRECISION MAXERR, LOCMAX + INTEGER GNFCN, PRZSTG, PRZY, PRZYP, PRZERS, PRZERR, + & PRZYNU + LOGICAL ERASON, ERASFL + COMMON /RKCOM6/ MAXERR, LOCMAX, GNFCN, PRZSTG, PRZY, PRZYP, + & PRZERS, PRZERR, PRZYNU, ERASON, ERASFL + SAVE /RKCOM6/ +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Parameters .. + DOUBLE PRECISION PT1, TEN, DUMMY + PARAMETER (PT1=0.1D0,TEN=10.0D0,DUMMY=1.0D0) +C .. Local Scalars .. + DOUBLE PRECISION DIFF, ERRMAX, HMIN, HSEC, MXERLC, TSEC, ZLERR, + & ZTEST1, ZTEST2 + INTEGER ISTEP, L, LEVEL + LOGICAL LDUMMY, MAIN +C .. Local Arrays .. + DOUBLE PRECISION DUMARR(1) +C .. External Subroutines .. + EXTERNAL STEP +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX +C .. Executable Statements .. + TSEC = T - HOLD + HSEC = HOLD/DBLE(NSEC) + HMIN = MAX(TINY,TOOSML*MAX(ABS(TSEC),ABS(T))) + IF (ABS(HSEC).LT.HMIN) THEN + IER = 6 + GO TO 120 + END IF + ZTEST1 = TOL/DBLE(NSEC) + ZTEST2 = TOL/TEN + LEVEL = 0 +C +C The subroutine STEP is used to take a step. In its use in the primary +C integration provision is made for getting on scale in the first step. +C In this situation only the subroutine might reduce the step size. By +C setting MAIN = .FALSE., the subroutine will take a step of the size input. +C In this use of the subroutine, all items of the call list appearing after +C MAIN are dummy variables. +C +C Perform secondary integration. + MAIN = .FALSE. + LDUMMY = .FALSE. + DO 60 ISTEP = 1, NSEC +C +C Take a step. + CALL STEP(F,NEQ,TSEC,ZY,ZYP,ZSTAGE,ZTEST1,HSEC,WEIGHT,ZYNEW, + & ZERRES,ZLERR,MAIN,DUMMY,DUMARR,LDUMMY) +C +C The primary integration is using a step size of HUSED and the secondary +C integration is using the smaller step size HSEC = HUSED/NSEC. If steps +C of this size were taken from the same starting point and the asymptotic +C behavior were evident, the smaller step size would result in a local error +C that is considerably smaller, namely by a factor of 1/(NSEC**(ORDER+1)). +C If the two approximate solutions are close and TOLR is neither too large nor +C too small, this should be approximately true. The step size is chosen in +C the primary integration so that the local error ERR is no larger than TOLR. +C The local error, ZLERR, of the secondary integration is compared to TOLR in +C an attempt to diagnose a secondary integration that is not rather more +C accurate than the primary integration. +C + IF (ZLERR.GE.ZTEST1) THEN + LEVEL = 2 + ELSE IF (ZLERR.GT.ZTEST2) THEN + LEVEL = LEVEL + 1 + END IF + IF (LEVEL.GE.2) THEN + IER = 6 + GO TO 120 + END IF +C +C Advance TSEC and the dependent variables ZY(*) and ZYP(*). + TSEC = T - DBLE(NSEC-ISTEP)*HSEC + DO 20 L = 1, NEQ + ZY(L) = ZYNEW(L) + 20 CONTINUE +C + IF (FSAL) THEN +C +C When FSAL = .TRUE., the derivative ZYP(*) is the last stage of the step. + DO 40 L = 1, NEQ + ZYP(L) = ZSTAGE(L,LSTSTG) + 40 CONTINUE + ELSE +C +C Call F to evaluate ZYP(*). + CALL F(TSEC,ZY,ZYP) + GNFCN = GNFCN + 1 + END IF +C + 60 CONTINUE +C +C Update the maximum error seen, MAXERR, and its location, LOCMAX. +C Use local variables ERRMAX and MXERLC. +C + ERRMAX = MAXERR + MXERLC = LOCMAX + DO 80 L = 1, NEQ + DIFF = ABS(ZY(L)-Y(L))/WEIGHT(L) + IF (DIFF.GT.ERRMAX) THEN + ERRMAX = DIFF + MXERLC = T + END IF + 80 CONTINUE +C +C If the global error is greater than 0.1D0, the solutions have diverged so +C far that comparing them may not provide a reliable estimate of the global +C error. The test is made before ZERROR(*) and MAXERR, LCMXER are updated so +C that on a failure, they refer to the last reliable results. +C + IF (ERRMAX.GT.PT1) THEN + IER = 6 + GO TO 120 + ELSE + MAXERR = ERRMAX + LOCMAX = MXERLC + DO 100 L = 1, NEQ + DIFF = ABS(ZY(L)-Y(L))/WEIGHT(L) + ZERROR(L) = ZERROR(L) + DIFF**2 + 100 CONTINUE + IER = 1 + END IF +C +C Exit point for TRUERR + 120 CONTINUE +C + RETURN + END + SUBROUTINE STEP(F,NEQ,TNOW,Y,YP,STAGES,TOL,HTRY,WEIGHT,YNEW, + & ERREST,ERR,MAIN,HMIN,THRES,PHASE2) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: To compute a step of an explicit Runge-Kutta +C method and estimate the local error of the step. +C +C Input: NEQ, TNOW, Y(*), YP(*), TOL, MAIN, HMIN, THRES(*) +C Input/output: HTRY, PHASE2, LAST, WEIGHT(*) +C Output: STAGES(NEQ,*), YNEW(*), ERREST(*), ERR +C +C Common: Initializes: none +C Reads: /RKCOM1/ TND +C /RKCOM2/ LAST +C /RKCOM4/ A, B, C, BHAT, PTR, NSTAGE, METHD +C /RKCOM5/ FSAL +C Alters: /RKCOM2/ NFCN, LAST +C /RKCOM6/ GNFCN +C +C Comments: +C ========= +C From an approximate solution Y(*) at TNOW and first derivative there, +C YP(*) = F(TNOW,Y,YP), a step is taken to get an approximation YNEW(*) +C at TNOW + HTRY. The Runge-Kutta method and how it is used are defined +C by A, B, C, BHAT, PTR, NSTAGE, METHD and FSAL. Intermediate stages +C of the method are stored in the array STAGES(NEQ,*). The error in +C each solution component is estimated and returned in ERREST(*). A +C weighted maximum norm of the local error, ERR, is formed. For some +C methods an intermediate error estimate can be computed before completion +C of the step (see routine STEPB); if the estimate is greater than the +C specified tolerance TOL, the computation of the step is terminated. +C +C When global error estimation is desired, two integrations are done. +C The usual integration is referred to as the "primary", or "main", +C integration (MAIN=.TRUE.). For global error estimation another, +C "secondary" integration (MAIN=.FALSE.) is carried out with a smaller +C step size. The weight vector WEIGHT(*) used in computing ERR is +C determined by the main integration. Thus this argument is output when +C MAIN = .TRUE. and input when MAIN = .FALSE.. +C +C When taking the first step in an integration, the logical variable +C PHASE2 may be input as .TRUE. and if the first step is the whole of +C the range of integration, then LAST will be .TRUE.. When PHASE2=.TRUE., +C the first three stages are monitored to help assure that the step +C size H is small enough for the integration to be stable and for the +C estimate of the error of the step to be credible. Calls are made to +C the subroutine STEPA for this purpose. If necessary, H will be +C reduced in STEPA (and LAST altered accordingly) and the step retried +C in STEP until an acceptable value is found. +C +C In the primary integration the number of calls to F is counted by +C NFCN, and in the secondary integration, by GNFCN. +C +C .. Scalar Arguments .. + DOUBLE PRECISION ERR, HMIN, HTRY, TNOW, TOL + INTEGER NEQ + LOGICAL MAIN, PHASE2 +C .. Array Arguments .. + DOUBLE PRECISION ERREST(*), STAGES(NEQ,*), THRES(*), WEIGHT(*), + & Y(*), YNEW(*), YP(*) +C .. Subroutine Arguments .. + EXTERNAL F +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block to hold Formula Definitions .. + DOUBLE PRECISION A(13,13), B(13), C(13), BHAT(13), R(11,6), + & E(7) + INTEGER PTR(13), NSTAGE, METHD, MINTP + LOGICAL INTP + COMMON /RKCOM4/ A, B, C, BHAT, R, E, PTR, NSTAGE, METHD, + & MINTP, INTP + SAVE /RKCOM4/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Global Error Assessment .. + DOUBLE PRECISION MAXERR, LOCMAX + INTEGER GNFCN, PRZSTG, PRZY, PRZYP, PRZERS, PRZERR, + & PRZYNU + LOGICAL ERASON, ERASFL + COMMON /RKCOM6/ MAXERR, LOCMAX, GNFCN, PRZSTG, PRZY, PRZYP, + & PRZERS, PRZERR, PRZYNU, ERASON, ERASFL + SAVE /RKCOM6/ +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0) +C .. Local Scalars .. + DOUBLE PRECISION AVGY, TSTG + INTEGER I, J, L + LOGICAL CUTBAK +C .. External Subroutines .. + EXTERNAL STEPA, STEPB +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN +C .. Executable Statements .. +C +C Many of the following loops over L = 1, NEQ have constant array values +C inside. The code is written with clarity in mind. Any optimizing +C compiler will identify these occurrences and take appropriate action. +C A check for zero multipliers has been included so as to prevent +C needless computation resulting from the storing of zero coefficients +C in the arrays for the sake of clarity. The array ERREST(*) is used +C for working storage in this computation. +C + 20 CONTINUE + IF (MAIN) THEN + IF (PHASE2) THEN +C +C Initialize weights for measuring the local error. + DO 40 L = 1, NEQ + WEIGHT(L) = MAX(THRES(L),ABS(Y(L))) + 40 CONTINUE + END IF + END IF +C + DO 140 I = 2, NSTAGE + DO 100 J = 1, I - 1 + IF (J.EQ.1) THEN + DO 60 L = 1, NEQ + ERREST(L) = A(I,1)*YP(L) + 60 CONTINUE + ELSE + IF (A(I,J).NE.ZERO) THEN + DO 80 L = 1, NEQ + ERREST(L) = ERREST(L) + A(I,J)*STAGES(L,PTR(J)) + 80 CONTINUE + END IF + END IF + 100 CONTINUE + DO 120 L = 1, NEQ + YNEW(L) = Y(L) + HTRY*ERREST(L) + 120 CONTINUE +C +C METHD = 2 is special in that an estimate of the local error can be +C formed before the step is completed. If the step is a failure, +C return immediately. Otherwise, complete the step and compute a more +C accurate error estimate. + IF (METHD.EQ.2 .AND. I.EQ.7) THEN + CALL STEPB(NEQ,Y,YP,HTRY,YNEW,STAGES,THRES,ERR,MAIN,WEIGHT) + IF (ERR.GT.TOL) RETURN + END IF +C + TSTG = TNOW + C(I)*HTRY + IF (MAIN .AND. LAST .AND. C(I).EQ.ONE) TSTG = TND + CALL F(TSTG,YNEW,STAGES(1,PTR(I))) +C +C Increment the counter for the number of function evaluations +C depending on whether the primary or secondary integration is taking +C place. + IF (MAIN) THEN + NFCN = NFCN + 1 + ELSE + GNFCN = GNFCN + 1 + END IF +C +C---------------------------------------------------------------------- +C When PHASE2 is .TRUE. we are in the second phase of the automatic +C selection of the initial step size. The results of the first three +C stages are monitored in the subroutine STEPA for evidence that H is +C too large -- instability and/or an unreliable estimate of the error +C of the step is then possible. When the subroutine believes H to be +C too large, it returns CUTBAK = .TRUE. and a suitably reduced H for +C another try. +C + IF (MAIN) THEN + IF (PHASE2) THEN + IF (I.LE.3 .AND. ABS(HTRY).GT.HMIN) THEN + CALL STEPA(TNOW,Y,YP,TSTG,YNEW,STAGES(1,PTR(I)), + & HTRY,WEIGHT,CUTBAK) + IF (CUTBAK) THEN + LAST = .FALSE. +C +C Make sure that STEPA does not reduce the step size below the +C minimum. If it does, reset H to HMIN and deactivate PHASE2. + IF (ABS(HTRY).LE.HMIN) THEN + HTRY = SIGN(HMIN,HTRY) + PHASE2 = .FALSE. + END IF + GO TO 20 + END IF + END IF + END IF + END IF +C---------------------------------------------------------------------- +C + 140 CONTINUE +C +C Some formulas are constructed so that the last stage represents +C the result of the step (FSAL=.TRUE.), hence if the step is acceptable, +C it will be the first stage for the next step. When FSAL=.FALSE., we +C have to complete the computation of the step. +C + IF (.NOT.FSAL) THEN + DO 200 I = 1, NSTAGE + IF (I.EQ.1) THEN + DO 160 L = 1, NEQ + ERREST(L) = BHAT(1)*YP(L) + 160 CONTINUE + ELSE + IF (BHAT(I).NE.ZERO) THEN + DO 180 L = 1, NEQ + ERREST(L) = ERREST(L) + BHAT(I)*STAGES(L,PTR(I)) + 180 CONTINUE + END IF + END IF + 200 CONTINUE + DO 220 L = 1, NEQ + YNEW(L) = Y(L) + HTRY*ERREST(L) + 220 CONTINUE + END IF +C +C Form an estimate of the error in the lower order formula by comparing +C it to the higher order formula of the pair. ERREST(*) has been used +C as working storage above. The higher order approximation has been +C formed as YNEW(*) = Y(*) + HTRY*ERREST(*) where ERREST(*) is a linear +C combination of the stages of the formula. The lower order result also +C has the form Y(*) plus HTRY times a different linear combination of +C the stages. Hence, this different linear combination of stages for +C the lower order formula can just be subtracted from the combination +C stored in ERREST(*) to produce the errors. The result is then +C multiplied by HTRY to obtain the error estimate. +C + DO 280 I = 1, NSTAGE + IF (I.EQ.1 .AND. B(1).NE.ZERO) THEN + DO 240 L = 1, NEQ + ERREST(L) = ERREST(L) - B(1)*YP(L) + 240 CONTINUE + ELSE + IF (B(I).NE.ZERO) THEN + DO 260 L = 1, NEQ + ERREST(L) = ERREST(L) - B(I)*STAGES(L,PTR(I)) + 260 CONTINUE + END IF + END IF + 280 CONTINUE + DO 300 L = 1, NEQ + ERREST(L) = HTRY*ERREST(L) + 300 CONTINUE +C +C The error in a solution component is measured relative to a weight +C that is the larger of a threshold and the size of the solution over +C the step. Using the magnitude of a solution component at both ends +C of the step in the definition of "size" increases the robustness of +C the test. When global error estimation is specified, the weight +C vector WEIGHT(*) is defined by the primary integration and is then +C used in the secondary integration. +C + IF (MAIN) THEN + DO 320 L = 1, NEQ + AVGY = HALF*(ABS(Y(L))+ABS(YNEW(L))) + WEIGHT(L) = MAX(AVGY,THRES(L)) + 320 CONTINUE + END IF +C + ERR = ZERO + DO 340 L = 1, NEQ + ERR = MAX(ERR,ABS(ERREST(L)/WEIGHT(L))) + 340 CONTINUE +C + RETURN + END + SUBROUTINE STEPA(TNOW,Y,YP,TSTG,YSTG,YPSTG,HTRY,WEIGHT,CUTBAK) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: To calculate an "on-scale" step size for phase 2 of +C the initial step size computation. +C +C Input: TNOW, Y(*), YP(*), TSTG, YSTG(*), YPSTG(*) +C Input/output: HTRY, WEIGHT +C Output: CUTBAK +C +C Common: Initializes: none +C Reads: /RKCOM1/ TND, NEQ +C /RKCOM5/ STBRAD, RS1, RS4 +C /RKCOM7/ RNDOFF +C Alters: none +C +C Comments: +C ========= +C This subroutine is used during the first three stages of the first step. +C A Lipschitz constant L for the differential equation in autonomous form +C is approximated, and the product abs(HTRY)*L is compared to an approximate +C radius, STBRAD, of the stability region of the method. The step size is +C reduced as necessary, within a range specified by the step size control +C parameters RS1 and RS4, to assure stability and give some confidence in +C the error estimator. If HTRY is reduced, CUTBAK is set .TRUE.. +C +C Y(*) and YP(*) contain the solution and its derivative at TNOW and +C similarly YSTG(*) and YPSTG(*) contain approximations at TSTG. +C +C Normally the weights used in the control of the error depend on the +C size of the solution at the beginning and at the end of the step, but +C at this time we do not have a solution at the end of the step. Each +C stage YSTG(*) of the Runge - Kutta process represents a low order +C approximation to the solution at TSTG. Because the initial value of +C WEIGHT(*) provided in the first phase of the scheme is based only on +C the solution at T and THRES(*), it is continually updated in STEPA to +C account for the size of the solution throughout the step as revealed +C by the intermediate stages YSTG(*). Inside this subroutine only, the +C differential equation is converted to autonomous form. After the +C conversion, the end of the interval of integration, TND, is used +C to define a suitable weight for the independent variable. +C +C .. Scalar Arguments .. + DOUBLE PRECISION HTRY, TNOW, TSTG + LOGICAL CUTBAK +C .. Array Arguments .. + DOUBLE PRECISION WEIGHT(*), Y(*), YP(*), YPSTG(*), YSTG(*) +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D0) +C .. Local Scalars .. + DOUBLE PRECISION ARGDIF, FDIFF, SCL, TDIFF, TWT, WT, YNRM, YSTGNM + INTEGER L +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. Executable Statements .. +C +C Update the weights to account for the current intermediate solution +C approximation YSTG(*). Compute the sizes of Y(*) and YSTG(*) in the +C new norm. The size of the Lipschitz constant is assessed by a difference +C in the arguments Y(*), YSTG(*) and a difference in the function evaluated +C at these arguments. +C + YNRM = ZERO + YSTGNM = ZERO + ARGDIF = ZERO + FDIFF = ZERO + DO 20 L = 1, NEQN + WT = MAX(WEIGHT(L),ABS(YSTG(L))) + WEIGHT(L) = WT + YNRM = MAX(YNRM,ABS(Y(L))/WT) + YSTGNM = MAX(YSTGNM,ABS(YSTG(L))/WT) + ARGDIF = MAX(ARGDIF,ABS(YSTG(L)-Y(L))/WT) + FDIFF = MAX(FDIFF,ABS(YPSTG(L)-YP(L))/WT) + 20 CONTINUE +C +C The transformation of the equation to autonomous form is done +C implicitly. The difference of the arguments must take into account +C the difference between the values of the independent variable T and +C TSTG. The difference of the corresponding component of the function +C is zero because of the way the standard transformation is done. +C + TDIFF = TSTG - TNOW + TWT = ABS(TND-TNOW) + YNRM = MAX(YNRM,ABS(TNOW)/TWT) + YSTGNM = MAX(YSTGNM,ABS(TSTG)/TWT) + ARGDIF = MAX(ARGDIF,ABS(TDIFF)/TWT) +C +C The ratio FDIFF/ARGDIF is a lower bound for, and an approximation to, a +C Lipschitz constant L for the differential equation written in autonomous +C form. First we must ask if the difference ARGDIF is significant in the +C precision available. If it appears to be, we insist that abs(HTRY)*L be +C less than an approximate radius, STBRAD, of the stability region of the +C method. This is more stringent than necessary for stability, possibly a +C lot more stringent, but the aim is to get an HTRY small enough that the +C error estimate for the step is credible. The reduction is required to be +C at least as much as the step control parameter RS1. It is necessary to +C limit the reduction of HTRY at any one time because we may be misled in +C the size of the reduction that is appropriate due to nonlinearity of the +C differential equation and to inaccurate weights caused by HTRY much too +C large. The reduction is not permitted to be more than the step control +C parameter RS4. +C + CUTBAK = .FALSE. + IF (ARGDIF.GT.RNDOFF*MAX(YNRM,YSTGNM)) THEN + IF ((ABS(HTRY)*FDIFF).GT.(STBRAD*ARGDIF)) THEN + SCL = (STBRAD*ARGDIF)/(ABS(HTRY)*FDIFF) + SCL = MIN(SCL,RS1) + SCL = MAX(SCL,RS4) + HTRY = SCL*HTRY + CUTBAK = .TRUE. + END IF + END IF +C + RETURN + END + SUBROUTINE STEPB(NEQ,Y,YP,H,YNEW,STAGES,THRES,ERR,MAIN,WEIGHT) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: To compute an error estimate for METHD = 2 prior +C to completing the step. +C +C Input: NEQ, Y(*), YP(*), H, STAGES(NEQ,*), THRES(*), MAIN, +C WEIGHT(*) +C Output: ERR +C +C Common: Initializes: none +C Reads: /RKCOM4/ E, PTR +C Alters: none +C +C Comments: +C ========= +C If global error assessment is taking place, then MAIN = .FALSE. and +C the weight vector generated by the primary integration is used. The +C error estimate is a linear combination (with coefficients in E(*)) +C of the stages stored in STAGES(*,*) (located by PTR(*)). +C +C .. Scalar Arguments .. + DOUBLE PRECISION ERR, H + INTEGER NEQ + LOGICAL MAIN +C .. Array Arguments .. + DOUBLE PRECISION STAGES(NEQ,*), THRES(*), WEIGHT(*), Y(*), + & YNEW(*), YP(*) +C .. Common Block to hold Formula Definitions .. + DOUBLE PRECISION A(13,13), B(13), C(13), BHAT(13), R(11,6), + & E(7) + INTEGER PTR(13), NSTAGE, METHD, MINTP + LOGICAL INTP + COMMON /RKCOM4/ A, B, C, BHAT, R, E, PTR, NSTAGE, METHD, + & MINTP, INTP + SAVE /RKCOM4/ +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF + PARAMETER (ZERO=0.0D0,HALF=0.5D0) +C .. Local Scalars .. + DOUBLE PRECISION AVGY, SUM, WT + INTEGER INDEX, L +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. Executable Statements .. +C + ERR = ZERO + DO 40 L = 1, NEQ +C +C Estimate the local error of component L. The coding makes use of +C E(2) = 0.0D0 and E(7) = 0.0D0. +C + SUM = E(1)*YP(L) + DO 20 INDEX = 3, 6 + SUM = SUM + E(INDEX)*STAGES(L,PTR(INDEX)) + 20 CONTINUE +C +C The local error is H*SUM. A weighted maximum norm of SUM is formed +C and then the factor of H is taken into account. +C + IF (MAIN) THEN + AVGY = HALF*(ABS(Y(L))+ABS(YNEW(L))) + WT = MAX(AVGY,THRES(L)) + ELSE + WT = WEIGHT(L) + END IF +C + ERR = MAX(ERR,ABS(SUM/WT)) + 40 CONTINUE + ERR = ABS(H)*ERR +C + RETURN + END + SUBROUTINE STIFF(F,HAVG,JFLSTP,TOOMCH,MAXFCN,WORK,IER,NREC) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: Diagnose stiffness. This depends on two things: whether +C the step size is being restricted on grounds of stability +C and whether the integration to TND can be completed in no +C more than MAXFCN function evaluations. +C +C Input: HAVG, TOOMCH, MAXFCN, WORK(*) +C Input/output: JFLSTP +C Output: IER, NREC +C Workspace: WORK(*) +C External: F +C +C Common: Initializes: /RKCOM9/ REC +C Reads: /RKCOM1/ TND, NEQN +C /RKCOM2/ T, H, NFCN, SVNFCN, OKSTP +C /RKCOM3/ PRY, PRYP, PRTHRS, PRWT, PRSCR, +C PRSTGS, PRYOLD +C /RKCOM5/ COST +C Alters: /RKCOM2/ NFCN +C /RKCOM9/ REC +C +C .. Scalar Arguments .. + DOUBLE PRECISION HAVG + INTEGER IER, JFLSTP, MAXFCN, NREC + LOGICAL TOOMCH +C .. Array Arguments .. + DOUBLE PRECISION WORK(*) +C .. Subroutine Arguments .. + EXTERNAL F +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block for General Workspace Pointers .. + INTEGER PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + COMMON /RKCOM3/ PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + SAVE /RKCOM3/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ +C .. Parameters .. + DOUBLE PRECISION HALF + PARAMETER (HALF=0.5D0) +C .. Local Scalars .. + DOUBLE PRECISION AVGY, XTRAWK + INTEGER L + LOGICAL LOTSFL, STIF, UNSURE +C .. External Subroutines .. + EXTERNAL STIFFA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MOD +C .. Executable Statements .. +C + IF (MOD(OKSTP-10,40).EQ.0) THEN + LOTSFL = JFLSTP .GE. 10 + JFLSTP = 0 + ELSE + LOTSFL = .FALSE. + END IF +C +C If either too much work has been done or there are lots of failed steps, +C test for stiffness. +C + IF (TOOMCH .OR. LOTSFL) THEN +C +C Regenerate weight vector + DO 20 L = 1, NEQN + AVGY = HALF*(ABS(WORK(PRY-1+L))+ABS(WORK(PRYOLD-1+L))) + WORK(PRWT-1+L) = MAX(AVGY,WORK(PRTHRS-1+L)) + 20 CONTINUE +C +C STIFFA determines whether the problem is STIFF. In some circumstances it +C is UNSURE. The decision depends on two things: whether the step size is +C being restricted on grounds of stability and whether the integration to +C TND can be completed in no more than MAXFCN function evaluations. The +C last four arguments of STIFFA are vectors of length NEQN used for working +C storage. Some storage in WORK(*) reserved for the stages (there are a +C minimum of three such vectors reserved for the METHDs implemented) and +C the scratch vector starting at PRSCR are used for this purpose. +C + CALL STIFFA(F,T,WORK(PRY),H,HAVG,TND,MAXFCN,WORK(PRWT), + & WORK(PRYP),WORK(PRERST),UNSURE,STIF,WORK(PRSTGS), + & WORK(PRSTGS+NEQN),WORK(PRSTGS+2*NEQN),WORK(PRSCR)) + IF (.NOT.UNSURE) THEN + IF (STIF) THEN +C +C Predict how much eXTRA WorK will be needed to reach TND. + XTRAWK = (COST*ABS((TND-T)/HAVG))/DBLE(SVNFCN+NFCN) + IER = 4 + WRITE (REC(NREC+1),'(A)') + &' ** Your problem has been diagnosed as stiff. If the ' + WRITE (REC(NREC+2),'(A,D13.5)') + &' ** situation persists, it will cost roughly ', XTRAWK + WRITE (REC(NREC+3),'(A)') + &' ** times as much to reach TEND as it has cost to reach TNOW.' + WRITE (REC(NREC+4),'(A)') + &' ** You should probably change to a code intended for ' + WRITE (REC(NREC+5),'(A)') + &' ** stiff problems. ' + NREC = NREC + 5 + END IF + END IF + END IF +C + RETURN + END + SUBROUTINE STIFFA(F,X,Y,HNOW,HAVG,XEND,MAXFCN,WT,FXY,V0,UNSURE, + & STIF,V1,V2,V3,VTEMP) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C External: F +C Input: X, Y(*), HNOW, HAVG, XEND, MAXFCN, WT(*), FXY(*) +C Input/Output V0(*) +C Output: UNSURE, STIF +C Workspace: V1(*), V2(*), V3(*), VTEMP(*) +C +C Common: Initializes: none +C Reads: /RKCOM1/ TND, NEQN +C /RKCOM5/ COST, STBRAD, TANANG +C /RKCOM7/ SQRRMC, CUBRMC +C Alters: none +C +C STIFFA diagnoses stiffness for an explicit Runge-Kutta code. When it +C is called, either many step failures have been observed, or a lot of +C work has been done. +C +C The NEQ equations of the problem are defined by the subroutine F(X,Y,YP). +C When STIFFA is called, the integration has reached X where the approximate +C solution is Y(*). The vector FXY(*) is defined by a call of F(X,Y,FXY). +C It is an input argument because it is usually available from the integrator. +C +C The last successful step was of size HNOW, and an average step size is +C HAVG. A weighted norm is used to measure the local error with the error +C in solution component L divided by the positive weight WT(L) provided in +C the vector WT(*). +C +C Explicit Runge - Kutta codes estimate the local error of Y(*) by +C forming the difference of two approximate solutions. This difference +C must be provided in the vector V0(*). When this difference is too +C small to be significant, STIFFA will replace it with a "random" vector. +C +C STIF is set .TRUE. when the average step size appears to be restricted +C on grounds of stability. In certain cases the variable UNSURE is set +C .TRUE.; the value of STIF is then not defined. +C +C The stability region of the explicit Runge-Kutta formula is described +C by quantities TANANG and STBRAD that are communicated by the setup routine +C via COMMON. Stability regions often change sharply near the imaginary +C axis so that it is difficult to classify the stiffness of a problem with +C eigenvalues of a local Jacobian that are "near" the imaginary axis. For +C this reason, we consider only points Z in the upper left half complex +C plane for which TAN( IMAG(Z)/( - RE(Z))) <= TANANG. Eigenvalues outside +C this region are one reason for the code being UNSURE. The stability +C region is approximated by the intersection of a disk with this sector. +C The radius of this disk is called STBRAD. +C +C Working storage must be provided via the four vectors V1(*),V2(*), +C V3(*),VTEMP(*). These vectors must be of length at least NEQ. +C +C .. Scalar Arguments .. + DOUBLE PRECISION HAVG, HNOW, X, XEND + INTEGER MAXFCN + LOGICAL STIF, UNSURE +C .. Array Arguments .. + DOUBLE PRECISION FXY(*), V0(*), V1(*), V2(*), V3(*), VTEMP(*), + & WT(*), Y(*) +C .. Subroutine Arguments .. + EXTERNAL F +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Parameters .. + DOUBLE PRECISION LARGE + PARAMETER (LARGE=1.0D+10) + DOUBLE PRECISION ZERO, P001, P9, ONE, TWO, FIVE, FIFTH + PARAMETER (ZERO=0.0D+0,P001=0.001D+0,P9=0.9D+0,ONE=1.0D+0, + & TWO=2.0D+0,FIVE=5.0D+0,FIFTH=0.2D+0) +C .. Local Scalars .. + DOUBLE PRECISION ALPHA1, ALPHA2, BETA1, BETA2, D1, D2, DET1, + & DET2, DIST, RES2, RHO, RHO2, ROLD, SCALE, V0NRM, + & V0V0, V0V1, V0V2, V1V1, V1V2, V1V3, V2V2, V2V3, + & V3NRM, V3V3, XTRFCN, YNRM + INTEGER L, NTRY + LOGICAL ROOTRE +C .. Local Arrays .. + DOUBLE PRECISION R1(2), R2(2), ROOT1(2), ROOT2(2) +C .. External Functions .. + DOUBLE PRECISION DOTPRD + EXTERNAL DOTPRD +C .. External Subroutines .. + EXTERNAL STIFFB, STIFFC, STIFFD +C .. Intrinsic Functions .. + INTRINSIC ABS, MIN, SQRT +C .. Executable Statements .. +C +C If the current step size differs substantially from the average, +C the problem is not stiff. +C + IF (ABS(HNOW/HAVG).GT.FIVE .OR. ABS(HNOW/HAVG).LT.FIFTH) THEN + STIF = .FALSE. + UNSURE = .FALSE. + RETURN + ELSE + UNSURE = .TRUE. + END IF +C +C The average step size is used to predict the cost in function evaluations +C of finishing the integration to XEND. If this cost is no more than MAXFCN, +C the problem is declared not stiff: If the step size is being restricted on +C grounds of stability, it will stay close to HAVG. The prediction will +C then be good, but the cost is too low to consider the problem stiff. If +C the step size is not close to HAVG, the problem is not stiff. Either way +C there is no point to testing for a step size restriction due to stability. +C + XTRFCN = COST*ABS((XEND-X)/HAVG) + IF (XTRFCN.LE.MAXFCN) THEN + STIF = .FALSE. + UNSURE = .FALSE. + RETURN + ELSE + UNSURE = .TRUE. + END IF +C +C There have been many step failures or a lot of work has been done. Now +C we must determine if this is due to the stability characteristics of the +C formula. This is done by calculating the dominant eigenvalues of the +C local Jacobian and then testing whether HAVG corresponds to being on the +C boundary of the stability region. +C +C The size of Y(*) provides scale information needed to approximate +C the Jacobian by differences. +C + YNRM = SQRT(DOTPRD(Y,Y,WT,NEQN)) + SCALE = YNRM*SQRRMC + IF (SCALE.EQ.ZERO) THEN +C +C Degenerate case. Y(*) is (almost) the zero vector so the scale is not +C defined. The input vector V0(*) is the difference between Y(*) and a +C lower order approximation to the solution that is within the error +C tolerance. When Y(*) vanishes, V0(*) is itself an acceptable approximate +C solution, so we take SCALE from it, if this is possible. +C + YNRM = SQRT(DOTPRD(V0,V0,WT,NEQN)) + SCALE = YNRM*SQRRMC + IF (SCALE.EQ.ZERO) THEN + UNSURE = .TRUE. + RETURN + END IF + END IF +C + V0V0 = DOTPRD(V0,V0,WT,NEQN) + IF (V0V0.EQ.ZERO) THEN +C +C Degenerate case. V0(*) is (almost) the zero vector so cannot +C be used to define a direction for an increment to Y(*). Try a +C "random" direction. +C + DO 20 L = 1, NEQN + V0(L) = ONE + 20 CONTINUE + V0V0 = DOTPRD(V0,V0,WT,NEQN) + END IF + V0NRM = SQRT(V0V0) + DO 40 L = 1, NEQN + V0(L) = V0(L)/V0NRM + 40 CONTINUE + V0V0 = ONE +C +C Use a nonlinear power method to estimate the two dominant eigenvalues. +C V0(*) is often very rich in the two associated eigenvectors. For this +C reason the computation is organized with the expectation that a minimal +C number of iterations will suffice. Indeed, it is necessary to recognize +C a kind of degeneracy when there is a dominant real eigenvalue. The +C subroutine STIFFB does this. In the first try, NTRY = 1, a Rayleigh +C quotient for such an eigenvalue is initialized as ROLD. After each +C iteration, REROOT computes a new Rayleigh quotient and tests whether the +C two approximations agree to one tenth of one per cent and the eigenvalue, +C eigenvector pair satisfy a stringent test on the residual. ROOTRE = .TRUE. +C signals that a single dominant real root has been found. +C + NTRY = 1 + 60 CONTINUE +C + CALL STIFFD(V0,HAVG,X,Y,F,FXY,WT,SCALE,V0V0,V1,V1V1,VTEMP) +C +C The quantity SQRT(V1V1/V0V0) is a lower bound for the product of HAVG +C and a Lipschitz constant. If it should be LARGE, stiffness is not +C restricting the step size to the stability region. The principle is +C clear enough, but the real reason for this test is to recognize an +C extremely inaccurate computation of V1V1 due to finite precision +C arithmetic in certain degenerate circumstances. +C + IF (SQRT(V1V1).GT.LARGE*SQRT(V0V0)) THEN + UNSURE = .TRUE. + RETURN + END IF +C + V0V1 = DOTPRD(V0,V1,WT,NEQN) + IF (NTRY.EQ.1) THEN + ROLD = V0V1/V0V0 +C +C This is the first Rayleigh quotient approximating the product of HAVG +C and a dominant real eigenvalue. If it should be very small, the +C problem is not stiff. It is important to test for this possibility so +C as to prevent underflow and degeneracies in the subsequent iteration. +C + IF (ABS(ROLD).LT.CUBRMC) THEN + UNSURE = .FALSE. + STIF = .FALSE. + RETURN + END IF + ELSE + CALL STIFFB(V1V1,V0V1,V0V0,ROLD,RHO,ROOT1,ROOT2,ROOTRE) + IF (ROOTRE) GO TO 100 + END IF + CALL STIFFD(V1,HAVG,X,Y,F,FXY,WT,SCALE,V1V1,V2,V2V2,VTEMP) + V0V2 = DOTPRD(V0,V2,WT,NEQN) + V1V2 = DOTPRD(V1,V2,WT,NEQN) + CALL STIFFB(V2V2,V1V2,V1V1,ROLD,RHO,ROOT1,ROOT2,ROOTRE) + IF (ROOTRE) GO TO 100 +C +C Fit a quadratic in the eigenvalue to the three successive iterates +C V0(*),V1(*),V2(*) of the power method to get a first approximation to +C a pair of eigenvalues. A test made earlier in STIFFB implies that +C the quantity DET1 here will not be too small. +C + DET1 = V0V0*V1V1 - V0V1**2 + ALPHA1 = (-V0V0*V1V2+V0V1*V0V2)/DET1 + BETA1 = (V0V1*V1V2-V1V1*V0V2)/DET1 +C +C Iterate again to get V3, test again for degeneracy, and then fit a +C quadratic to V1(*),V2(*),V3(*) to get a second approximation to a pair +C of eigenvalues. +C + CALL STIFFD(V2,HAVG,X,Y,F,FXY,WT,SCALE,V2V2,V3,V3V3,VTEMP) + V1V3 = DOTPRD(V1,V3,WT,NEQN) + V2V3 = DOTPRD(V2,V3,WT,NEQN) + CALL STIFFB(V3V3,V2V3,V2V2,ROLD,RHO,ROOT1,ROOT2,ROOTRE) + IF (ROOTRE) GO TO 100 + DET2 = V1V1*V2V2 - V1V2**2 + ALPHA2 = (-V1V1*V2V3+V1V2*V1V3)/DET2 + BETA2 = (V1V2*V2V3-V2V2*V1V3)/DET2 +C +C First test the residual of the quadratic fit to see if we might +C have determined a pair of eigenvalues. +C + RES2 = ABS(V3V3+V2V2*ALPHA2**2+V1V1*BETA2**2+TWO*V2V3*ALPHA2+ + & TWO*V1V3*BETA2+TWO*V1V2*ALPHA2*BETA2) + IF (RES2.LE.V3V3*P001**2) THEN +C +C Calculate the two approximate pairs of eigenvalues. +C + CALL STIFFC(ALPHA1,BETA1,R1,R2) + CALL STIFFC(ALPHA2,BETA2,ROOT1,ROOT2) +C +C The test for convergence is done on the larger root of the second +C approximation. It is complicated by the fact that one pair of roots +C might be real and the other complex. First calculate the spectral +C radius RHO of HAVG*J as the magnitude of ROOT1. Then see if one of +C the roots R1,R2 is within one per cent of ROOT1. A subdominant root +C may be very poorly approximated if its magnitude is much smaller than +C RHO -- this does not matter in our use of these eigenvalues. +C + RHO = SQRT(ROOT1(1)**2+ROOT1(2)**2) + D1 = (ROOT1(1)-R1(1))**2 + (ROOT1(2)-R1(2))**2 + D2 = (ROOT1(1)-R2(1))**2 + (ROOT1(2)-R2(2))**2 + DIST = SQRT(MIN(D1,D2)) + IF (DIST.LE.P001*RHO) GO TO 100 + END IF +C +C Do not have convergence yet. Because the iterations are cheap, and +C because the convergence criterion is stringent, we are willing to try +C a few iterations. +C + IF (NTRY.LT.MAXTRY) THEN + NTRY = NTRY + 1 + V3NRM = SQRT(V3V3) + DO 80 L = 1, NEQN + V0(L) = V3(L)/V3NRM + 80 CONTINUE + V0V0 = ONE + GO TO 60 + ELSE + UNSURE = .TRUE. + RETURN + END IF +C +C ************** +C +C We now have the dominant eigenvalues. Decide if the average step +C size is being restricted on grounds of stability. Check the real +C parts of the eigenvalues. First see if the dominant eigenvalue is +C in the left half plane -- there won't be a stability restriction +C unless it is. If there is another eigenvalue of comparable magnitude +C with a positive real part, the problem is not stiff. If the dominant +C eigenvalue is too close to the imaginary axis, we cannot diagnose +C stiffness. +C + 100 CONTINUE + IF (ROOT1(1).GT.ZERO) THEN + STIF = .FALSE. + UNSURE = .FALSE. + RETURN + END IF + RHO2 = SQRT(ROOT2(1)**2+ROOT2(2)**2) + IF (RHO2.GE.P9*RHO .AND. ROOT2(1).GT.ZERO) THEN + STIF = .FALSE. + UNSURE = .FALSE. + RETURN + END IF + IF (ABS(ROOT1(2)).GT.ABS(ROOT1(1))*TANANG) THEN + UNSURE = .TRUE. + RETURN + END IF +C +C If the average step size corresponds to being well within the +C stability region, the step size is not being restricted because +C of stability. +C + STIF = RHO .GE. P9*STBRAD + UNSURE = .FALSE. + RETURN + END + SUBROUTINE STIFFB(V1V1,V0V1,V0V0,ROLD,RHO,ROOT1,ROOT2,ROOTRE) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Input: V1V1, V0V1, V0V0 +C Input/output: ROLD +C Output: RHO, ROOT1(*),ROOT2(*),ROOTRE +C +C Decide if the iteration has degenerated because of a strongly +C dominant real eigenvalue. Have just computed the latest iterate. +C V1V1 is its dot product with itself, V0V1 is the dot product +C of the previous iterate with the current one, and V0V0 is the +C dot product of the previous iterate with itself. ROLD is a +C previous Rayleigh quotient approximating a dominant real +C eigenvalue. It must be computed directly the first time the +C subroutine is called. It is updated each call to STIFFB, hence +C is available for subsequent calls. +C +C If there is a strongly dominant real eigenvalue, ROOTRE is set +C .TRUE., ROOT1(*) returns the eigenvalue, RHO returns the magnitude +C of the eigenvalue, and ROOT2(*) is set to zero. +C +C .. Scalar Arguments .. + DOUBLE PRECISION RHO, ROLD, V0V0, V0V1, V1V1 + LOGICAL ROOTRE +C .. Array Arguments .. + DOUBLE PRECISION ROOT1(2), ROOT2(2) +C .. Parameters .. + DOUBLE PRECISION ZERO, P001 + PARAMETER (ZERO=0.0D+0,P001=0.001D+0) +C .. Local Scalars .. + DOUBLE PRECISION DET, R, RES +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + R = V0V1/V0V0 + RHO = ABS(R) + DET = V0V0*V1V1 - V0V1**2 + RES = ABS(DET/V0V0) + ROOTRE = DET .EQ. ZERO .OR. (RES.LE.V1V1*P001**2 .AND. + & ABS(R-ROLD).LE.P001*RHO) + IF (ROOTRE) THEN + ROOT1(1) = R + ROOT1(2) = ZERO + ROOT2(1) = ZERO + ROOT2(2) = ZERO + END IF + ROLD = R +C + RETURN + END + SUBROUTINE STIFFC(ALPHA,BETA,R1,R2) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Input: ALPHA, BETA +C Output: R1(*), R2(*) +C +C This subroutine computes the two complex roots R1 and R2 of +C the quadratic equation X**2 + ALPHA*X + BETA = 0. The magnitude +C of R1 is greater than or equal to the magnitude of R2. R1 and R2 are +C returned as vectors of two components with the first being the real +C part of the complex number and the second being the imaginary part. +C +C .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION R1(2), R2(2) +C .. Parameters .. + DOUBLE PRECISION ZERO, TWO + PARAMETER (ZERO=0.0D+0,TWO=2.0D+0) +C .. Local Scalars .. + DOUBLE PRECISION DISC, SQDISC, TEMP +C .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +C .. Executable Statements .. + TEMP = ALPHA/TWO + DISC = TEMP**2 - BETA + IF (DISC.EQ.ZERO) THEN +C +C Double root. +C + R1(1) = -TEMP + R1(2) = ZERO + R2(1) = R1(1) + R2(2) = R1(2) + RETURN + END IF +C + SQDISC = SQRT(ABS(DISC)) + IF (DISC.LT.ZERO) THEN +C +C Complex conjugate roots. +C + R1(1) = -TEMP + R1(2) = SQDISC + R2(1) = R1(1) + R2(2) = -R1(2) + ELSE +C +C Real pair of roots. Calculate the bigger one in R1(1). +C + IF (TEMP.GT.ZERO) THEN + R1(1) = -TEMP - SQDISC + ELSE + R1(1) = -TEMP + SQDISC + END IF + R1(2) = ZERO + R2(1) = BETA/R1(1) + R2(2) = ZERO + END IF +C + RETURN + END + SUBROUTINE STIFFD(V,HAVG,X,Y,F,FXY,WT,SCALE,VDOTV,Z,ZDOTZ,VTEMP) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C External: F +C Input: V(*), HAVG, X, Y(*), FXY(*), WT(*), SCALE, VDOTV, +C Output: Z(*), ZDOTZ +C Workspace: VTEMP(*) +C +C For an input vector V(*) of length NEQ, this subroutine computes a vector +C Z(*) that approximates the product HAVG*J*V where HAVG is an input scalar +C and J is the Jacobian matrix of a function F evaluated at the input +C arguments (X,Y(*)). This function is defined by a subroutine of the form +C F(T,U,F) that when given T and U(*), returns the value of the function in +C F(*). The input vector FXY(*) is defined by F(X,Y,FXY). Scaling is a +C delicate matter. A weighted Euclidean norm is used with the (positive) +C weights provided in WT(*). The input scalar SCALE is the square root of +C the unit roundoff times the norm of Y(*). The square of the norm of the +C input vector V(*) is input as VDOTV. The routine outputs the square of +C the norm of the output vector Z(*) as ZDOTZ. The subroutine calls the +C DOUBLE PRECISION FUNCTION DOTPRD(U,V,WT,NEQ) to compute the dot (inner) +C product. The vector VTEMP(*) is used for working storage. +C +C .. Scalar Arguments .. + DOUBLE PRECISION HAVG, SCALE, VDOTV, X, ZDOTZ +C .. Array Arguments .. + DOUBLE PRECISION FXY(*), V(*), VTEMP(*), WT(*), Y(*), Z(*) +C .. Subroutine Arguments .. + EXTERNAL F +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Local Scalars .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER L +C .. External Functions .. + DOUBLE PRECISION DOTPRD + EXTERNAL DOTPRD +C .. Intrinsic Functions .. + INTRINSIC SQRT +C .. Executable Statements .. +C +C Scale V(*) so that it can be used as an increment to Y(*) +C for an accurate difference approximation to the Jacobian. +C + TEMP1 = SCALE/SQRT(VDOTV) + DO 20 L = 1, NEQN + VTEMP(L) = Y(L) + TEMP1*V(L) + 20 CONTINUE +C + CALL F(X,VTEMP,Z) + NFCN = NFCN + 1 +C +C Form the difference approximation. At the same time undo +C the scaling of V(*) and introduce the factor of HAVG. +C + TEMP2 = HAVG/TEMP1 + DO 40 L = 1, NEQN + Z(L) = TEMP2*(Z(L)-FXY(L)) + 40 CONTINUE +C + ZDOTZ = DOTPRD(Z,Z,WT,NEQN) +C + RETURN + END + DOUBLE PRECISION FUNCTION DOTPRD(U,V,WT,NEQ) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: To compute a weighted Euclidean dot (inner) product of +C two vectors. +C +C Input: U(*), V(*), WT(*), NEQ +C Output: the result DOTPRD is returned via the subprogram name +C +C Comments: +C ========= +C The vectors U(*), V(*), and WT(*) are of length NEQ. The components +C of WT(*) are weights that must be non-zero. +C +C .. Scalar Arguments .. + INTEGER NEQ +C .. Array Arguments .. + DOUBLE PRECISION U(*), V(*), WT(*) +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D0) +C .. Local Scalars .. + DOUBLE PRECISION SUM + INTEGER L +C .. Executable Statements .. +C + SUM = ZERO + DO 20 L = 1, NEQ + SUM = SUM + (U(L)/WT(L))*(V(L)/WT(L)) + 20 CONTINUE +C + DOTPRD = SUM +C + RETURN + END + SUBROUTINE SOFTFL(ASK,ON) +C +C Purpose: To prevent a program STOP after a "catastrophic" +C failure when using a routine from RKSUITE. +C +C Input: ASK +C Input/output: ON +C +C Comments: +C ========= +C When a "catastrophic" failure is detected, the default action of +C RKSUITE is to write an explanation to the standard output channel, +C OUTCH, and STOP. This subroutine can be used to prevent the STOP and +C so allow the main program to continue. To do this, you call SOFTFL with +C ASK = .FALSE. and ON = .TRUE. You must then call the subroutine CHKFL +C after every call to a user-callable routine in RKSUITE to check whether +C a catastrophic error occurred and take appropriate action if it did. Of +C course, you may call SETUP at any time to start a new problem, but calling +C any other user-callable routine in RKSUITE after a catastrophic error will +C lead to a STOP (even when "soft failure" has been set "on"). +C +C When ON is set by a call to SOFTFL with ASK = .FALSE., the value of ON +C is SAVEd. The subroutine RKMSG in RKSUITE calls SOFTFL with ASK = .TRUE. +C to find out the SAVEd value of ON. +C +C .. Scalar Arguments .. + LOGICAL ASK, ON +C .. Local Scalars .. + LOGICAL SOFT +C .. Save statement .. + SAVE SOFT +C .. Data statements .. + DATA SOFT/.FALSE./ +C .. Executable Statements .. +C + IF (ASK) THEN + ON = SOFT + ELSE + SOFT = ON + END IF +C + RETURN + END + SUBROUTINE CHKFL(ASK,ERROR) +C +C Purpose: Enquiry routine used in conjunction with SOFTFL. +C Reports whether a "catastrophic" error was detected. +C +C Input: ASK +C Input/output: ERROR +C +C Comments: +C ========= +C When a "catastrophic" failure is detected, the default action of +C RKSUITE is to write an explanation to the standard output channel, +C OUTCH, and STOP. SOFTFL can be used to prevent the STOP and so +C allow the main program to continue. It is then necessary to call +C CHKFL with ASK = .TRUE. after every call to a user-callable routine +C in RKSUITE to check whether a catastrophic error occurred and take +C appropriate action if it did. If there was a catastrophic error, +C ERROR is returned .TRUE. Of course, you may call SETUP at any time +C to start a new problem, but calling any other user-callable routine +C in RKSUITE after a catastrophic error will lead to a STOP (even when +C "soft failure" has been set "on"). +C +C When a catastrophic failure (IER = 911) is detected in one of +C the routines in RKSUITE, it calls CHKFL with ASK = .FALSE. and +C ERROR = .TRUE. This value of ERROR is SAVEd. +C +C .. Scalar Arguments .. + LOGICAL ASK, ERROR +C .. Local Scalars .. + LOGICAL SAVERR +C .. Save statement .. + SAVE SAVERR +C .. Data statements .. + DATA SAVERR/.FALSE./ +C .. Executable Statements .. +C + IF (ASK) THEN + ERROR = SAVERR + ELSE + SAVERR = ERROR + END IF +C + RETURN + END diff --git a/rksuite/rksuite.org.f b/rksuite/rksuite.org.f new file mode 100644 index 0000000..17651eb --- /dev/null +++ b/rksuite/rksuite.org.f @@ -0,0 +1,4939 @@ + SUBROUTINE SETUP(NEQ,TSTART,YSTART,TEND,TOL,THRES,METHOD,TASK, + & ERRASS,HSTART,WORK,LENWRK,MESAGE) +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C +C If you are not familiar with the code SETUP and how it is used in +C conjunction with UT or CT to solve initial value problems, you should study +C the document file rksuite.doc carefully before attempting to use the code. +C The following "Brief Reminder" is intended only to remind you of the +C meaning, type, and size requirements of the arguments. +C +C The environmental parameters OUTCH, MCHEPS, and DWARF are used in the +C following description. To find out their values +C +C CALL ENVIRN(OUTCH,MCHEPS,DWARF) +C +C INPUT VARIABLES +C +C NEQ - INTEGER +C The number of differential equations in the system. +C Constraint: NEQ >= 1 +C TSTART - DOUBLE PRECISION +C The initial value of the independent variable. +C YSTART(*) - DOUBLE PRECISION array of length NEQ +C The vector of initial values of the solution components. +C TEND - DOUBLE PRECISION +C The integration proceeds from TSTART in the direction of +C TEND. You cannot go past TEND. +C Constraint: TEND must be clearly distinguishable from TSTART +C in the precision available. +C TOL - DOUBLE PRECISION +C The relative error tolerance. +C Constraint: 0.01D0 >= TOL >= 10*MCHEPS +C THRES(*) - DOUBLE PRECISION array of length NEQ +C THRES(L) is the threshold for the Ith solution component. +C Constraint: THRES(L) >= SQRT(DWARF) +C METHOD - INTEGER +C Specifies which Runge-Kutta pair is to be used. +C = 1 - use the (2,3) pair +C = 2 - use the (4,5) pair +C = 3 - use the (7,8) pair +C TASK - CHARACTER*(*) +C Only the first character of TASK is significant. +C TASK(1:1) = `U' or `u' - UT is to be used +C = `C' or `c' - CT is to be used +C Constraint: TASK(1:1) = `U'or `u' or`C' or `c' +C ERRASS - LOGICAL +C = .FALSE. - do not attempt to assess the true error. +C = .TRUE. - assess the true error. Costs roughly twice +C as much as the integration with METHODs 2 and +C 3, and three times with METHOD = 1. +C HSTART - DOUBLE PRECISION +C 0.0D0 - select automatically the first step size. +C non-zero - try HSTART for the first step. +C +C WORKSPACE +C +C WORK(*) - DOUBLE PRECISION array of length LENWRK +C Do not alter the contents of this array after calling SETUP. +C +C INPUT VARIABLES +C +C LENWRK - INTEGER +C Length of WORK(*): How big LENWRK must be depends +C on the task and how it is to be solved. +C +C LENWRK = 32*NEQ is sufficient for all cases. +C +C If storage is a problem, the least storage possible +C in the various cases is: +C +C If TASK = `U' or `u', then +C if ERRASS = .FALSE. and +C METHOD = 1, LENWRK must be at least 10*NEQ +C = 2 20*NEQ +C = 3 16*NEQ +C if ERRASS = .TRUE. and +C METHOD = 1, LENWRK must be at least 15*NEQ +C = 2 32*NEQ +C = 3 21*NEQ +C +C If TASK = `C' or `c', then +C if ERRASS = .FALSE. and +C METHOD = 1, LENWRK must be at least 10*NEQ +C = 2 14*NEQ +C = 3 16*NEQ +C if ERRASS = .TRUE. and +C METHOD = 1, LENWRK must be at least 15*NEQ +C = 2 26*NEQ +C = 3 21*NEQ +C +C Warning: To exploit the interpolation capability +C of METHODs 1 and 2, you have to call INTRP. This +C subroutine requires working storage in addition to +C that specified here. +C +C MESAGE - LOGICAL +C Specifies whether you want informative messages written to +C the standard output channel OUTCH. +C = .TRUE. - provide messages +C = .FALSE. - do not provide messages +C +C In the event of a "catastrophic" failure to call SETUP correctly, the +C nature of the catastrophe is reported on the standard output channel, +C regardless of the value of MESAGE. Unless special provision was made +C in advance (see rksuite.doc), the computation then comes to a STOP. +C +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C .. Scalar Arguments .. + DOUBLE PRECISION HSTART, TEND, TOL, TSTART + INTEGER LENWRK, METHOD, NEQ + LOGICAL ERRASS, MESAGE + CHARACTER*(*) TASK +C .. Array Arguments .. + DOUBLE PRECISION THRES(*), WORK(*), YSTART(*) +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block for General Workspace Pointers .. + INTEGER PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + COMMON /RKCOM3/ PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + SAVE /RKCOM3/ +C .. Common Block to hold Formula Definitions .. + DOUBLE PRECISION A(13,13), B(13), C(13), BHAT(13), R(11,6), + & E(7) + INTEGER PTR(13), NSTAGE, METHD, MINTP + LOGICAL INTP + COMMON /RKCOM4/ A, B, C, BHAT, R, E, PTR, NSTAGE, METHD, + & MINTP, INTP + SAVE /RKCOM4/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Global Error Assessment .. + DOUBLE PRECISION MAXERR, LOCMAX + INTEGER GNFCN, PRZSTG, PRZY, PRZYP, PRZERS, PRZERR, + & PRZYNU + LOGICAL ERASON, ERASFL + COMMON /RKCOM6/ MAXERR, LOCMAX, GNFCN, PRZSTG, PRZY, PRZYP, + & PRZERS, PRZERR, PRZYNU, ERASON, ERASFL + SAVE /RKCOM6/ +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Common Block for Integrator Options .. + LOGICAL MSG, UTASK + COMMON /RKCOM8/ MSG, UTASK + SAVE /RKCOM8/ +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ +C .. Parameters .. + CHARACTER*6 SRNAME + PARAMETER (SRNAME='SETUP') + INTEGER MINUS1 + LOGICAL TELL + PARAMETER (MINUS1=-1,TELL=.FALSE.) + DOUBLE PRECISION ONE, ZERO, PT01 + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0,PT01=0.01D+0) +C .. Local Scalars .. + DOUBLE PRECISION HMIN + INTEGER FLAG, FREEPR, IER, L, LINTPL, LREQ, NREC, VECSTG + LOGICAL LEGALT, REQSTG + CHARACTER TASK1 +C .. External Subroutines .. + EXTERNAL CONST, MCONST, RKMSG, RKSIT +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN +C .. Executable Statements .. +C +C Clear previous flag values of subprograms in the suite. +C + IER = MINUS1 + CALL RKSIT(TELL,SRNAME,IER) +C + IER = 1 + NREC = 0 +C +C Fetch output channel and machine constants; initialise common +C block /RKCOM7/ +C + CALL MCONST(METHOD) +C +C Check for valid input of trivial arguments + TASK1 = TASK(1:1) + LEGALT = TASK1 .EQ. 'U' .OR. TASK1 .EQ. 'u' .OR. + & TASK1 .EQ. 'C' .OR. TASK1 .EQ. 'c' + IF (.NOT.LEGALT) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A/A,A,A/A)') + &' ** You have set the first character of ', + &' ** TASK to be ''',TASK1,'''. It must be one of ', + &' ** ''U'',''u'',''C'' or ''c''.' + ELSE IF (NEQ.LT.1) THEN + IER = 911 + NREC = 1 + WRITE (REC,'(A,I6,A)') + &' ** You have set NEQ = ',NEQ,' which is less than 1.' + ELSE IF (METHOD.LT.1 .OR. METHOD.GT.3) THEN + IER = 911 + NREC = 1 + WRITE (REC,'(A,I6,A)') + &' ** You have set METHOD = ',METHOD,' which is not 1, 2, or 3.' + ELSE IF (TSTART.EQ.TEND) THEN + IER = 911 + NREC = 1 + WRITE (REC,'(A,D13.5,A)') + &' ** You have set TSTART = TEND = ',TSTART,'.' + ELSE IF ((TOL.GT.PT01) .OR. (TOL.LT.RNDOFF)) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A,D13.5,A/A,D13.5,A)') + &' ** You have set TOL = ',TOL,' which is not permitted. The', + &' ** range of permitted values is (',RNDOFF,',0.01D0).' + ELSE + L = 1 + 20 CONTINUE + IF (THRES(L).LT.TINY) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A,I6,A,D13.5,A/A,D13.5,A)') + &' ** You have set THRES(',L,') to be ',THRES(L),' which is ', + &' ** less than the permitted minimum,',TINY,'.' + END IF + L = L + 1 + IF (IER.NE.911 .AND. L.LE.NEQ) GO TO 20 + END IF +C +C Return if error detected +C + IF (IER.NE.1) GO TO 80 +C +C Set formula definitions and characteristics by means of arguments +C in the call list and COMMON blocks /RKCOM4/ and /RKCOM5/ +C + CALL CONST(METHOD,VECSTG,REQSTG,LINTPL) +C +C Set options in /RKCOM8/ + UTASK = TASK1 .EQ. 'U' .OR. TASK1 .EQ. 'u' + MSG = MESAGE +C +C Initialise problem status in /RKCOM1/ and /RKCOM2/ + NEQN = NEQ + TSTRT = TSTART + TND = TEND + T = TSTART + TOLD = TSTART + DIR = SIGN(ONE,TEND-TSTART) +C +C In CT the first step taken will have magnitude H. If HSTRT = ABS(HSTART) +C is not equal to zero, H = HSTRT. If HSTRT is equal to zero, the code is +C to find an on-scale initial step size H. To start this process, H is set +C here to an upper bound on the first step size that reflects the scale of +C the independent variable. UT has some additional information, namely the +C first output point, that is used to refine this bound in UT when UTASK +C is .TRUE.. If HSTRT is not zero, but it is either too big or too small, +C the input HSTART is ignored and HSTRT is set to zero to activate the +C automatic determination of an on-scale initial step size. +C + HSTRT = ABS(HSTART) + HMIN = MAX(TINY,TOOSML*MAX(ABS(TSTART),ABS(TEND))) + IF (HSTRT.GT.ABS(TEND-TSTART) .OR. HSTRT.LT.HMIN) HSTRT = ZERO + IF (HSTRT.EQ.ZERO) THEN + H = MAX(ABS(TEND-TSTART)/RS3,HMIN) + ELSE + H = HSTRT + END IF + HOLD = ZERO + TOLR = TOL + NFCN = 0 + SVNFCN = 0 + OKSTP = 0 + FLSTP = 0 + FIRST = .TRUE. + LAST = .FALSE. +C +C WORK(*) is partioned into a number of arrays using pointers. These +C pointers are set in /RKCOM3/. + PRTHRS = 1 +C the threshold values + PRERST = PRTHRS + NEQ +C the error estimates + PRWT = PRERST + NEQ +C the weights used in the local error test + PRYOLD = PRWT + NEQ +C the previous value of the solution + PRSCR = PRYOLD + NEQ +C scratch array used for the higher order +C approximate solution and for the previous +C value of the derivative of the solution + PRY = PRSCR + NEQ +C the dependent variables + PRYP = PRY + NEQ +C the derivatives + PRSTGS = PRYP + NEQ +C intermediate stages held in an internal +C array STAGES(NEQ,VECSTG) +C + FREEPR = PRSTGS + VECSTG*NEQ +C +C Allocate storage for interpolation if the TASK = `U' or `u' was +C specified. INTP and LINTPL returned by CONST indicate whether there +C is an interpolation scheme associated with the pair and how much +C storage is required. +C + PRINTP = 1 + LNINTP = 1 + IF (UTASK) THEN + IF (INTP) THEN + LNINTP = LINTPL*NEQ + IF (REQSTG) THEN + PRINTP = FREEPR + FREEPR = PRINTP + LNINTP + ELSE + PRINTP = PRSTGS + FREEPR = MAX(PRINTP+VECSTG*NEQ,PRINTP+LNINTP) + END IF + END IF + END IF +C +C Initialise state and allocate storage for global error assessment +C using /RKCOM6/ + GNFCN = 0 + MAXERR = ZERO + LOCMAX = TSTART + ERASON = ERRASS + ERASFL = .FALSE. + IF (ERRASS) THEN +C +C Storage is required for the stages of a secondary integration. The +C stages of the primary intergration can only be overwritten in the +C cases where there is no interpolant or the interpolant does not +C require information about the stages (e.g. METHOD 3 and METHOD 1, +C respectively). + IF (.NOT.REQSTG) THEN + PRZSTG = PRSTGS + ELSE + PRZSTG = FREEPR + FREEPR = PRZSTG + VECSTG*NEQ + END IF + PRZY = FREEPR + PRZYP = PRZY + NEQ + PRZERS = PRZYP + NEQ + PRZERR = PRZERS + NEQ + PRZYNU = PRZERR + NEQ + FREEPR = PRZYNU + NEQ + ELSE + PRZSTG = 1 + PRZY = 1 + PRZYP = 1 + PRZERS = 1 + PRZERR = 1 + PRZYNU = 1 + END IF +C + LREQ = FREEPR - 1 +C +C Check for enough workspace and suitable range of integration +C + IF (LENWRK.LT.LREQ) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A/A,I6,A,I6,A)') + &' ** You have not supplied enough workspace. You gave LENWRK ', + &' ** as', LENWRK, ', but it must be at least ',LREQ,'.' + ELSE + HMIN = MAX(TINY,TOOSML*MAX(ABS(TSTART),ABS(TEND))) + IF (ABS(TEND-TSTART).LT.HMIN) THEN + IER = 911 + NREC = 4 + WRITE (REC,'(A/A/A,D13.5/A,D13.5,A)') + &' ** You have set values for TEND and TSTART that are not ', + &' ** clearly distinguishable for the method and the precision ', + &' ** of the computer being used. ABS(TEND-TSTART) is ', + &ABS(TEND-TSTART), + &' ** but should be at least ',HMIN,'.' + END IF + END IF +C +C Return if error detected +C + IF (IER.NE.1) GO TO 80 +C +C Initialize elements of the workspace + DO 40 L = 1, NEQ + WORK(PRTHRS-1+L) = THRES(L) + WORK(PRY-1+L) = YSTART(L) + 40 CONTINUE +C +C Initialize the global error to zero when ERRASS = .TRUE. + IF (ERRASS) THEN + DO 60 L = 1, NEQ + WORK(PRZERR-1+L) = ZERO + 60 CONTINUE + END IF +C + 80 CONTINUE +C + CALL RKMSG(IER,SRNAME,NREC,FLAG) +C + RETURN + END + SUBROUTINE UT(F,TWANT,TGOT,YGOT,YPGOT,YMAX,WORK,UFLAG) +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C +C If you are not familiar with the code UT and how it is used in +C conjunction with SETUP to solve initial value problems, you should study +C the document file rksuite.doc carefully before proceeding further. The +C following "Brief Reminder" is intended only to remind you of the meaning, +C type, and size requirements of the arguments. +C +C NAME DECLARED IN AN EXTERNAL STATEMENT IN THE CALLING PROGRAM: +C +C F - name of the subroutine for evaluating the differential +C equations. +C +C The subroutine F must have the form +C +C SUBROUTINE F(T,Y,YP) +C DOUBLE PRECISION T,Y(*),YP(*) +C Given input values of the independent variable T and the solution +C components Y(*), for each L = 1,2,...,NEQ evaluate the differential +C equation for the derivative of the Ith solution component and place the +C value in YP(L). Do not alter the input values of T and Y(*). +C RETURN +C END +C +C INPUT VARIABLE +C +C TWANT - DOUBLE PRECISION +C The next value of the independent variable where a +C solution is desired. +C +C Constraints: TWANT must lie between the previous value +C of TGOT (TSTART on the first call) and TEND. TWANT can be +C equal to TEND, but it must be clearly distinguishable from +C the previous value of TGOT (TSTART on the first call) in +C the precision available. +C +C OUTPUT VARIABLES +C +C TGOT - DOUBLE PRECISION +C A solution has been computed at this value of the +C independent variable. +C YGOT(*) - DOUBLE PRECISION array of length NEQ +C Approximation to the true solution at TGOT. Do not alter +C the contents of this array +C YPGOT(*) - DOUBLE PRECISION array of length NEQ +C Approximation to the first derivative of the true +C solution at TGOT. +C YMAX(*) - DOUBLE PRECISION array of length NEQ +C YMAX(L) is the largest magnitude of YGOT(L) computed at any +C time in the integration from TSTART to TGOT. Do not alter +C the contents of this array. +C +C WORKSPACE +C +C WORK(*) - DOUBLE PRECISION array as used in SETUP +C Do not alter the contents of this array. +C +C OUTPUT VARIABLE +C +C UFLAG - INTEGER +C +C SUCCESS. TGOT = TWANT. +C = 1 - Complete success. +C +C "SOFT" FAILURES +C = 2 - Warning: You are using METHOD = 3 inefficiently +C by computing answers at many values of TWANT. If +C you really need answers at so many specific points, +C it would be more efficient to compute them with +C METHOD = 2. To do this you would need to restart +C from TGOT, YGOT(*) by a call to SETUP. If you wish +C to continue as you are, you may. +C = 3 - Warning: A considerable amount of work has been +C expended. If you wish to continue on to TWANT, just +C call UT again. +C = 4 - Warning: It appears that this problem is "stiff". +C You really should change to another code that is +C intended for such problems, but if you insist, you can +C continue with UT by calling it again. +C +C "HARD" FAILURES +C = 5 - You are asking for too much accuracy. You cannot +C continue integrating this problem. +C = 6 - The global error assessment may not be reliable beyond +C the current point in the integration. You cannot +C continue integrating this problem. +C +C "CATASTROPHIC" FAILURES +C = 911 - The nature of the catastrophe is reported on +C the standard output channel. Unless special +C provision was made in advance (see rksuite.doc), +C the computation then comes to a STOP. +C +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C .. Scalar Arguments .. + DOUBLE PRECISION TGOT, TWANT + INTEGER UFLAG +C .. Array Arguments .. + DOUBLE PRECISION WORK(*), YGOT(*), YMAX(*), YPGOT(*) +C .. Subroutine Arguments .. + EXTERNAL F +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block for General Workspace Pointers .. + INTEGER PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + COMMON /RKCOM3/ PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + SAVE /RKCOM3/ +C .. Common Block to hold Formula Definitions .. + DOUBLE PRECISION A(13,13), B(13), C(13), BHAT(13), R(11,6), + & E(7) + INTEGER PTR(13), NSTAGE, METHD, MINTP + LOGICAL INTP + COMMON /RKCOM4/ A, B, C, BHAT, R, E, PTR, NSTAGE, METHD, + & MINTP, INTP + SAVE /RKCOM4/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Common Block for Integrator Options .. + LOGICAL MSG, UTASK + COMMON /RKCOM8/ MSG, UTASK + SAVE /RKCOM8/ +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ +C .. Parameters .. + CHARACTER*6 SRNAME + PARAMETER (SRNAME='UT') + LOGICAL ASK, TELL + PARAMETER (ASK=.TRUE.,TELL=.FALSE.) + INTEGER MINUS1, MINUS2 + PARAMETER (MINUS1=-1,MINUS2=-2) + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +C .. Local Scalars .. + DOUBLE PRECISION HMIN, TLAST, TNOW, UTEND + INTEGER CFLAG, IER, L, NREC, STATE + LOGICAL BADERR, GOBACK +C .. External Subroutines .. + EXTERNAL CHKFL, CT, INTRP, RESET, RKMSG, RKSIT +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. Save statement .. + SAVE UTEND, TLAST +C .. Executable Statements .. + IER = 1 + NREC = 0 + GOBACK = .FALSE. + BADERR = .FALSE. +C +C Is it permissible to call UT? +C + CALL RKSIT(ASK,'SETUP',STATE) + IF (STATE.EQ.911) THEN + IER = 912 + NREC = 1 + WRITE (REC,'(A)') + &' ** A catastrophic error has already been detected elsewhere.' + GO TO 100 + END IF + IF (STATE.EQ.MINUS1) THEN + IER = 911 + NREC = 1 + WRITE (REC,'(A)') + &' ** You have not called SETUP, so you cannot use UT.' + GO TO 100 + END IF + IF (.NOT.UTASK) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A/A)') + &' ** You have called UT after you specified in SETUP that ', + &' ** you were going to use CT. This is not permitted.' + GO TO 100 + END IF + CALL RKSIT(ASK,SRNAME,STATE) + IF (STATE.EQ.5 .OR. STATE.EQ.6) THEN + IER = 911 + NREC = 1 + WRITE (REC,'(A/A)') + &' ** This routine has already returned with a hard failure.', + &' ** You must call SETUP to start another problem.' + GO TO 100 + END IF + STATE = MINUS2 + CALL RKSIT(TELL,SRNAME,STATE) +C + IF (FIRST) THEN +C +C First call. +C +C A value of TND is specified in SETUP. When INTP = .FALSE., as with +C METHD = 3, output is obtained at the specified TWANT by resetting TND +C to TWANT. At this point, before the integration gets started, this can +C be done with a simple assignment. Later it is done with a call to RESET. +C The original TND is SAVEd as a local variable UTEND. +C + UTEND = TND + IF (.NOT.INTP) TND = TWANT +C +C The last TGOT returned is SAVEd in the variable TLAST. T (a variable +C passed through the common block RKCOM2) records how far the integration +C has advanced towards the specified TND. When output is obtained by +C interpolation, the integration goes past the TGOT returned (T is closer +C to the specified TND than TGOT). Initialize these variables and YMAX(*). + TLAST = TSTRT + TGOT = TSTRT + DO 20 L = 1, NEQN + YMAX(L) = ABS(WORK(PRY-1+L)) + 20 CONTINUE +C +C If the code is to find an on-scale initial step size H, a bound was placed +C on H in SETUP. Here the first output point is used to refine this bound. + IF (HSTRT.EQ.ZERO) THEN + H = MIN(ABS(H),ABS(TWANT-TSTRT)) + HMIN = MAX(TINY,TOOSML*MAX(ABS(TSTRT),ABS(TND))) + H = MAX(H,HMIN) + END IF +C + ELSE +C +C Subsequent call. +C + IF (TLAST.EQ.UTEND) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A/A/A)') + &' ** You have called UT after reaching TEND. (Your last ', + &' ** call to UT resulted in TGOT = TEND.) To start a new ', + &' ** problem, you will need to call SETUP.' + GO TO 100 + END IF +C + END IF +C +C Check for valid TWANT. +C + IF (DIR*(TWANT-TLAST).LE.ZERO) THEN + IER = 911 + NREC = 4 + WRITE (REC,'(A/A/A/A)') + &' ** You have made a call to UT with a TWANT that does ', + &' ** not lie between the previous value of TGOT (TSTART ', + &' ** on the first call) and TEND. This is not permitted. ', + &' ** Check your program carefully.' + GO TO 100 + END IF + IF (DIR*(TWANT-UTEND).GT.ZERO) THEN + HMIN = MAX(TINY,TOOSML*MAX(ABS(TWANT),ABS(UTEND))) + IF (ABS(TWANT-UTEND).LT.HMIN) THEN + IER = 911 + NREC = 5 + WRITE (REC,'(A/A/A/A)') + &' ** You have made a call to UT with a TWANT that does ', + &' ** not lie between the previous value of TGOT (TSTART on ', + &' ** the first call) and TEND. This is not permitted. TWANT ', + &' ** is very close to TEND, so you may have meant to set ', + &' ** it to be TEND exactly. Check your program carefully. ' + ELSE + IER = 911 + NREC = 4 + WRITE (REC,'(A/A/A/A)') + &' ** You have made a call to UT with a TWANT that does ', + &' ** not lie between the previous value of TGOT (TSTART ', + &' ** on the first call) and TEND. This is not permitted. ', + &' ** Check your program carefully.' + END IF + GO TO 100 + END IF + IF (.NOT.INTP) THEN + HMIN = MAX(TINY,TOOSML*MAX(ABS(TLAST),ABS(TWANT))) + IF (ABS(TWANT-TLAST).LT.HMIN) THEN + IER = 911 + NREC = 4 + WRITE (REC,'(A/A/A/A,D13.5,A)') + &' ** You have made a call to UT with a TWANT that is not ', + &' ** sufficiently different from the last value of TGOT ', + &' ** (TSTART on the first call). When using METHOD = 3, ', + &' ** it must differ by at least ',HMIN,'.' + GO TO 100 + END IF +C +C We have a valid TWANT. There is no interpolation with this METHD and +C therefore we step to TWANT exactly by resetting TND with a call to RESET. +C On the first step this matter is handled differently as explained above. +C + IF (.NOT.FIRST) THEN + CALL RESET(TWANT) + CALL CHKFL(ASK,BADERR) + IF (BADERR) GO TO 100 + END IF + END IF +C +C Process output, decide whether to take another step. +C + 40 CONTINUE +C + IF (INTP) THEN +C +C Interpolation is possible with this METHD. The integration has +C already reached T. If this is past TWANT, GOBACK is set .TRUE. and +C the answers are obtained by interpolation. +C + GOBACK = DIR*(T-TWANT) .GE. ZERO + IF (GOBACK) THEN + CALL INTRP(TWANT,'Both solution and derivative',NEQN,YGOT, + & YPGOT,F,WORK,WORK(PRINTP),LNINTP) + CALL CHKFL(ASK,BADERR) + IF (BADERR) GO TO 100 + TGOT = TWANT + END IF + ELSE +C +C Interpolation is not possible with this METHD, so output is obtained +C by integrating to TWANT = TND. Both YGOT(*) and YPGOT(*) are then +C already loaded with the solution at TWANT by CT. +C + GOBACK = T .EQ. TWANT + IF (GOBACK) TGOT = TWANT + END IF +C +C Updating of YMAX(*) is done here to account for the fact that when +C interpolation is done, the integration goes past TGOT. Note that YGOT(*) +C is not defined until CT is called. YMAX(*) was initialized at TSTRT +C from values stored in WORK(*), so only needs to be updated for T +C different from TSTRT. + IF (T.NE.TSTRT) THEN + DO 60 L = 1, NEQN + YMAX(L) = MAX(YMAX(L),ABS(YGOT(L))) + 60 CONTINUE + END IF +C +C If done, go to the exit point. + IF (GOBACK) GO TO 100 +C +C Take a step with CT in the direction of TND. On exit, the solution is +C advanced to TNOW. The way CT is written, the approximate solution at +C TNOW is available in both YGOT(*) and in WORK(*). If output is obtained by +C stepping to the end (TNOW = TWANT = TND), YGOT(*) can be returned directly. +C If output is obtained by interpolation, the subroutine INTRP that does this +C uses the values in WORK(*) for its computations and places the approximate +C solution at TWANT in the array YGOT(*) for return to the calling program. +C The approximate derivative is handled in the same way. TNOW is output from +C CT and is actually a copy of T declared above in a common block. +C + CALL CT(F,TNOW,YGOT,YPGOT,WORK,CFLAG) + IER = CFLAG +C +C A successful step by CT is indicated by CFLAG = 1 or = 2. + IF (CFLAG.EQ.1) THEN + GO TO 40 + ELSE IF (CFLAG.EQ.2) THEN +C +C Supplement the warning message written in CT. + NREC = 3 + WRITE (REC,'(A/A/A)') + &' ** The last message was produced on a call to CT from UT. ', + &' ** In UT the appropriate action is to change to METHOD = 2,', + &' ** or, if insufficient memory is available, to METHOD = 1. ' + ELSE IF (CFLAG.LE.6) THEN + NREC = 1 + WRITE (REC,'(A)') + &' ** The last message was produced on a call to CT from UT.' + ELSE + BADERR = .TRUE. + END IF + TGOT = T +C +C Update YMAX(*) before the return. + DO 80 L = 1, NEQN + YMAX(L) = MAX(YMAX(L),ABS(YGOT(L))) + 80 CONTINUE +C +C Exit point for UT. +C + 100 CONTINUE +C + IF (BADERR) THEN + IER = 911 + NREC = 4 + WRITE (REC,'(A/A/A/A)') + &' ** An internal call by UT to a subroutine resulted in an ', + &' ** error that should not happen. Check your program ', + &' ** carefully for array sizes, correct number of arguments,', + &' ** type mismatches ... .' + END IF +C + TLAST = TGOT +C +C All exits are done here after a call to RKMSG to report +C what happened and set UFLAG. +C + CALL RKMSG(IER,SRNAME,NREC,UFLAG) +C + RETURN + END + SUBROUTINE STAT(TOTFCN,STPCST,WASTE,STPSOK,HNEXT) +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C +C If you are not familiar with the code STAT and how it is used in +C conjunction with the integrators CT and UT, you should study the +C document file rksuite.doc carefully before attempting to use the code. +C The following "Brief Reminder" is intended only to remind you of the +C meaning, type, and size requirements of the arguments. +C +C STAT is called to obtain some details about the integration. +C +C OUTPUT VARIABLES +C +C TOTFCN - INTEGER +C Total number of calls to F in the integration so far -- +C a measure of the cost of the integration. +C STPCST - INTEGER +C Cost of a typical step with this METHOD measured in +C calls to F. +C WASTE - DOUBLE PRECISION +C The number of attempted steps that failed to meet the +C local error requirement divided by the total number of +C steps attempted so far in the integration. +C STPSOK - INTEGER +C The number of accepted steps. +C HNEXT - DOUBLE PRECISION +C The step size the integrator plans to use for the next step. +C +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C .. Scalar Arguments .. + DOUBLE PRECISION HNEXT, WASTE + INTEGER STPCST, STPSOK, TOTFCN +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Global Error Assessment .. + DOUBLE PRECISION MAXERR, LOCMAX + INTEGER GNFCN, PRZSTG, PRZY, PRZYP, PRZERS, PRZERR, + & PRZYNU + LOGICAL ERASON, ERASFL + COMMON /RKCOM6/ MAXERR, LOCMAX, GNFCN, PRZSTG, PRZY, PRZYP, + & PRZERS, PRZERR, PRZYNU, ERASON, ERASFL + SAVE /RKCOM6/ +C .. Common Block for Integrator Options .. + LOGICAL MSG, UTASK + COMMON /RKCOM8/ MSG, UTASK + SAVE /RKCOM8/ +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ +C .. Parameters .. + CHARACTER*6 SRNAME + PARAMETER (SRNAME='STAT') + LOGICAL ASK + INTEGER MINUS1, MINUS2 + PARAMETER (ASK=.TRUE.,MINUS1=-1,MINUS2=-2) + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +C .. Local Scalars .. + INTEGER FLAG, IER, NREC, STATE +C .. External Subroutines .. + EXTERNAL RKMSG, RKSIT +C .. Intrinsic Functions .. + INTRINSIC DBLE +C .. Executable Statements .. +C + IER = 1 + NREC = 0 +C +C Is it permissible to call STAT? +C + CALL RKSIT(ASK,SRNAME,STATE) + IF (STATE.EQ.911) THEN + IER = 912 + NREC = 1 + WRITE (REC,'(A)') + &' ** A catastrophic error has already been detected elsewhere.' + GO TO 20 + END IF + IF (STATE.EQ.MINUS2) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A/A/A)') + &' ** You have already made a call to STAT after a hard ', + &' ** failure was reported from the integrator. You cannot', + &' ** call STAT again.' + GO TO 20 + END IF + CALL RKSIT(ASK,'CT',STATE) + IF (STATE.EQ.MINUS1) THEN + IER = 911 + NREC = 1 + IF (UTASK) THEN + WRITE (REC,'(A)') + &' ** You have not called UT, so you cannot use STAT.' + ELSE + WRITE (REC,'(A)') + &' ** You have not called CT, so you cannot use STAT.' + END IF + GO TO 20 + END IF +C +C Set flag so that the routine can only be called once after a hard +C failure from the integrator. + IF (STATE.EQ.5 .OR. STATE.EQ.6) IER = MINUS2 +C + TOTFCN = SVNFCN + NFCN + IF (ERASON) TOTFCN = TOTFCN + GNFCN + STPCST = COST + STPSOK = OKSTP + IF (OKSTP.LE.1) THEN + WASTE = ZERO + ELSE + WASTE = DBLE(FLSTP)/DBLE(FLSTP+OKSTP) + END IF + HNEXT = H +C + 20 CONTINUE +C + CALL RKMSG(IER,SRNAME,NREC,FLAG) +C + RETURN + END + SUBROUTINE GLBERR(RMSERR,ERRMAX,TERRMX,WORK) +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C +C If you are not familiar with the code GLBERR and how it is used in +C conjunction with UT and CT to solve initial value problems, you should +C study the document file rksuite.doc carefully before attempting to use +C the code. The following "Brief Reminder" is intended only to remind you +C of the meaning, type, and size requirements of the arguments. +C +C If ERRASS was set .TRUE. in the call to SETUP, then after any call to UT +C or CT to advance the integration to TNOW or TWANT, the subroutine GLBERR +C may be called to obtain an assessment of the true error of the integration. +C At each step and for each solution component Y(L), a more accurate "true" +C solution YT(L), an average magnitude "size(L)" of its size, and its error +C abs(Y(L) - YT(L))/max("size(L)",THRES(L)) +C are computed. The assessment returned in RMSERR(L) is the RMS (root-mean- +C square) average of the error in the Lth solution component over all steps +C of the integration from TSTART through TNOW. +C +C OUTPUT VARIABLES +C +C RMSERR(*) - DOUBLE PRECISION array of length NEQ +C RMSERR(L) approximates the RMS average of the true error +C of the numerical solution for the Ith solution component, +C L = 1,2,...,NEQ. The average is taken over all steps from +C TSTART to TNOW. +C ERRMAX - DOUBLE PRECISION +C The maximum (approximate) true error taken over all +C solution components and all steps from TSTART to TNOW. +C TERRMX - DOUBLE PRECISION +C First value of the independent variable where the +C (approximate) true error attains the maximum value ERRMAX. +C +C WORKSPACE +C +C WORK(*) - DOUBLE PRECISION array as used in SETUP and UT or CT +C Do not alter the contents of this array. +C +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C .. Scalar Arguments .. + DOUBLE PRECISION ERRMAX, TERRMX +C .. Array Arguments .. + DOUBLE PRECISION RMSERR(*), WORK(*) +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block for Global Error Assessment .. + DOUBLE PRECISION MAXERR, LOCMAX + INTEGER GNFCN, PRZSTG, PRZY, PRZYP, PRZERS, PRZERR, + & PRZYNU + LOGICAL ERASON, ERASFL + COMMON /RKCOM6/ MAXERR, LOCMAX, GNFCN, PRZSTG, PRZY, PRZYP, + & PRZERS, PRZERR, PRZYNU, ERASON, ERASFL + SAVE /RKCOM6/ +C .. Common Block for Integrator Options .. + LOGICAL MSG, UTASK + COMMON /RKCOM8/ MSG, UTASK + SAVE /RKCOM8/ +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ +C .. Parameters .. + CHARACTER*6 SRNAME + PARAMETER (SRNAME='GLBERR') + LOGICAL ASK + PARAMETER (ASK=.TRUE.) + INTEGER MINUS1, MINUS2 + PARAMETER (MINUS1=-1,MINUS2=-2) +C .. Local Scalars .. + INTEGER FLAG, IER, L, NREC, STATE +C .. External Subroutines .. + EXTERNAL RKMSG, RKSIT +C .. Intrinsic Functions .. + INTRINSIC SQRT +C .. Executable Statements .. +C + IER = 1 + NREC = 0 +C +C Is it permissible to call GLBERR? +C + CALL RKSIT(ASK,SRNAME,STATE) + IF (STATE.EQ.911) THEN + IER = 912 + NREC = 1 + WRITE (REC,'(A)') + &' ** A catastrophic error has already been detected elsewhere.' + GO TO 40 + END IF + IF (STATE.EQ.MINUS2) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A/A/A)') + &' ** You have already made a call to GLBERR after a hard ', + &' ** failure was reported from the integrator. You cannot', + &' ** call GLBERR again.' + GO TO 40 + END IF + CALL RKSIT(ASK,'CT',STATE) + IF (STATE.EQ.MINUS1) THEN + IER = 911 + NREC = 1 + IF (UTASK) THEN + WRITE (REC,'(A)') + &' ** You have not yet called UT, so you cannot call GLBERR.' + ELSE + WRITE (REC,'(A)') + &' ** You have not yet called CT, so you cannot call GLBERR.' + END IF + GO TO 40 + END IF +C +C Set flag so that the routine can only be called once after a hard +C failure from the integrator. + IF (STATE.EQ.5 .OR. STATE.EQ.6) IER = MINUS2 +C +C Check that ERRASS was set properly for error assessment in SETUP. +C + IF (.NOT.ERASON) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A/A/A)') + &' ** No error assessment is available since you did not ', + &' ** ask for it in your call to the routine SETUP.', + &' ** Check your program carefully.' + GO TO 40 + END IF +C +C Check to see if the integrator has not actually taken a step. +C + IF (OKSTP.EQ.0) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A/A/A)') + &' ** The integrator has not actually taken any successful ', + &' ** steps. You cannot call GLBERR in this circumstance. ', + &' ** Check your program carefully.' + GO TO 40 + END IF +C +C Compute RMS error and set output variables. +C + ERRMAX = MAXERR + TERRMX = LOCMAX + DO 20 L = 1, NEQN + RMSERR(L) = SQRT(WORK(PRZERR-1+L)/OKSTP) + 20 CONTINUE +C + 40 CONTINUE +C + CALL RKMSG(IER,SRNAME,NREC,FLAG) +C + RETURN + END + SUBROUTINE CT(F,TNOW,YNOW,YPNOW,WORK,CFLAG) +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C +C If you are not familiar with the code CT and how it is used in +C conjunction with SETUP to solve initial value problems, you should study +C the document file rksuite.doc carefully before attempting to use the code. +C The following "Brief Reminder" is intended only to remind you of the +C meaning, type, and size requirements of the arguments. +C +C NAME DECLARED IN AN EXTERNAL STATEMENT IN THE CALLING PROGRAM: +C +C F - name of the subroutine for evaluating the differential +C equations. +C +C The subroutine F must have the form +C +C SUBROUTINE F(T,Y,YP) +C DOUBLE PRECISION T,Y(*),YP(*) +C Using the input values of the independent variable T and the solution +C components Y(*), for each L = 1,2,...,NEQ evaluate the differential +C equation for the derivative of the Lth solution component and place the +C value in YP(L). Do not alter the input values of T and Y(*). +C RETURN +C END +C +C OUTPUT VARIABLES +C +C TNOW - DOUBLE PRECISION +C Current value of the independent variable. +C YNOW(*) - DOUBLE PRECISION array of length NEQ +C Approximation to the true solution at TNOW. +C YPNOW(*) - DOUBLE PRECISION array of length NEQ +C Approximation to the first derivative of the +C true solution at TNOW. +C +C WORKSPACE +C +C WORK(*) - DOUBLE PRECISION array as used in SETUP +C Do not alter the contents of this array. +C +C OUTPUT VARIABLE +C +C CFLAG - INTEGER +C +C SUCCESS. A STEP WAS TAKEN TO TNOW. +C = 1 - Complete success. +C +C "SOFT" FAILURES +C = 2 - Warning: You have obtained an answer by integrating +C to TEND (TNOW = TEND). You have done this at least +C 100 times, and monitoring of the computation reveals +C that this way of getting output has degraded the +C efficiency of the code. If you really need answers at +C so many specific points, it would be more efficient to +C get them with INTRP. (If METHOD = 3, you would need +C to change METHOD and restart from TNOW, YNOW(*) by a +C call to SETUP.) If you wish to continue as you are, +C you may. +C = 3 - Warning: A considerable amount of work has been +C expended. To continue the integration, just call +C CT again. +C = 4 - Warning: It appears that this problem is "stiff". +C You really should change to another code that is +C intended for such problems, but if you insist, you +C can continue with CT by calling it again. +C +C "HARD" FAILURES +C = 5 - You are asking for too much accuracy. You cannot +C continue integrating this problem. +C = 6 - The global error assessment may not be reliable beyond +C the current point in the integration. You cannot +C continue integrating this problem. +C +C "CATASTROPHIC" FAILURES +C = 911 - The nature of the catastrophe is reported on +C the standard output channel. Unless special +C provision was made in advance (see rksuite.doc), +C the computation then comes to a STOP. +C +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C .. Scalar Arguments .. + DOUBLE PRECISION TNOW + INTEGER CFLAG +C .. Array Arguments .. + DOUBLE PRECISION WORK(*), YNOW(*), YPNOW(*) +C .. Subroutine Arguments .. + EXTERNAL F +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block for General Workspace Pointers .. + INTEGER PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + COMMON /RKCOM3/ PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + SAVE /RKCOM3/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Global Error Assessment .. + DOUBLE PRECISION MAXERR, LOCMAX + INTEGER GNFCN, PRZSTG, PRZY, PRZYP, PRZERS, PRZERR, + & PRZYNU + LOGICAL ERASON, ERASFL + COMMON /RKCOM6/ MAXERR, LOCMAX, GNFCN, PRZSTG, PRZY, PRZYP, + & PRZERS, PRZERR, PRZYNU, ERASON, ERASFL + SAVE /RKCOM6/ +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Common Block for Integrator Options .. + LOGICAL MSG, UTASK + COMMON /RKCOM8/ MSG, UTASK + SAVE /RKCOM8/ +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ +C .. Parameters .. + CHARACTER*6 SRNAME + PARAMETER (SRNAME='CT') + LOGICAL ASK, TELL + PARAMETER (ASK=.TRUE.,TELL=.FALSE.) + INTEGER MINUS1, MINUS2 + PARAMETER (MINUS1=-1,MINUS2=-2) + INTEGER MAXFCN + PARAMETER (MAXFCN=5000) + DOUBLE PRECISION ZERO, PT1, PT9, ONE, TWO, HUNDRD + PARAMETER (ZERO=0.0D+0,PT1=0.1D+0,PT9=0.9D+0,ONE=1.0D+0, + & TWO=2.0D+0,HUNDRD=100.0D+0) +C .. Local Scalars .. + DOUBLE PRECISION ALPHA, BETA, ERR, ERROLD, HAVG, HMIN, HTRY, TAU, + & TEMP1, TEMP2, YPNORM + INTEGER IER, JFLSTP, L, NREC, NTEND, POINT, STATE, YNEW, + & YPOLD + LOGICAL CHKEFF, FAILED, MAIN, PHASE1, PHASE2, PHASE3, + & TOOMCH +C .. External Subroutines .. + EXTERNAL RKMSG, RKSIT, STEP, STIFF, TRUERR +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SIGN +C .. Save statement .. + SAVE JFLSTP, NTEND, ERROLD, HAVG, PHASE2, YNEW, + & YPOLD, CHKEFF +C .. Executable Statements .. +C + IER = 1 + NREC = 0 +C +C Is it permissible to call CT? +C + CALL RKSIT(ASK,'SETUP',STATE) + IF (STATE.EQ.911) THEN + IER = 912 + NREC = 1 + WRITE (REC,'(A)') + &' ** A catastrophic error has already been detected elsewhere.' + GO TO 180 + END IF + IF (STATE.EQ.MINUS1) THEN + IER = 911 + NREC = 1 + WRITE (REC,'(A)') + &' ** You have not called SETUP, so you cannot use CT.' + GO TO 180 + END IF + IF (UTASK) THEN + CALL RKSIT(ASK,'UT',STATE) + IF (STATE.NE.MINUS2) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A/A)') + &' ** You have called CT after you specified in SETUP that ', + &' ** you were going to use UT. This is not permitted.' + UTASK = .FALSE. + GO TO 180 + END IF + END IF + CALL RKSIT(ASK,SRNAME,STATE) + IF (STATE.EQ.5 .OR. STATE.EQ.6) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A/A)') + &' ** CT has already returned with a flag value of 5 or 6.', + &' ** You cannot continue integrating this problem. You must ', + &' ** call SETUP to start another problem.' + GO TO 180 + END IF +C + IF (FIRST) THEN +C +C First call in an integration -- initialize everything. +C + CHKEFF = .FALSE. + NTEND = 0 + JFLSTP = 0 +C +C A scratch area of WORK(*) starting at PRSCR is used to hold two +C arrays in this subroutine: the higher order approximate solution at +C the end of a step and the approximate derivative of the solution at +C the end of the last step. To make this clear, local pointers YNEW and +C YPOLD are used. + YNEW = PRSCR + YPOLD = PRSCR +C +C For this first step T was initialized to TSTRT in SETUP and the +C starting values YSTART(*) were loaded into the area of WORK(*) reserved +C for the current solution approximation starting at location PRY. The +C derivative is now computed and stored in WORK(*) starting at PRYP. +C Subsequently these arrays are copied to the output vectors YNOW(*) +C and YPNOW(*). + CALL F(T,WORK(PRY),WORK(PRYP)) + NFCN = NFCN + 1 + DO 20 L = 1, NEQN + YNOW(L) = WORK(PRY-1+L) + YPNOW(L) = WORK(PRYP-1+L) + 20 CONTINUE +C +C Set dependent variables for error assessment. + IF (ERASON) THEN + DO 40 L = 1, NEQN + WORK(PRZY-1+L) = YNOW(L) + WORK(PRZYP-1+L) = YPNOW(L) + 40 CONTINUE + END IF +C +C The weights for the control of the error depend on the size of the +C solution at the beginning and at the end of the step. On the first +C step we do not have all this information. Whilst determining the +C initial step size we initialize the weight vector to the larger of +C abs(Y(L)) and the threshold for this component. + DO 60 L = 1, NEQN + WORK(PRWT-1+L) = MAX(ABS(YNOW(L)),WORK(PRTHRS-1+L)) + 60 CONTINUE +C +C If HSTRT is equal to zero, the code is to find an on-scale initial step +C size H. CT has an elaborate scheme of three phases for finding such an H, +C and some preparations are made earlier. In SETUP an upper bound is placed +C on H that reflects the scale of the independent variable. When UTASK is +C .TRUE., UT refines this bound using the first output point. Here in CT +C PHASE1 applies a rule of thumb based on the error control, the order of the +C the formula, and the size of the initial slope to get a crude approximation +C to an on-scale H. PHASE2 may reduce H in the course of taking the first +C step. PHASE3 repeatedly adjusts H and retakes the first step until H is +C on scale. +C +C A guess for the magnitude of the first step size H can be provided to SETUP +C as HSTART. If it is too big or too small, it is ignored and the automatic +C determination of an on-scale initial step size is activated. If it is +C acceptable, H is set to HSTART in SETUP. Even when H is supplied to CT, +C PHASE3 of the scheme for finding an on-scale initial step size is made +C active so that the code can deal with a bad guess. +C + PHASE1 = HSTRT .EQ. ZERO + PHASE2 = PHASE1 + PHASE3 = .TRUE. + IF (PHASE1) THEN + H = ABS(H) + YPNORM = ZERO + DO 80 L = 1, NEQN + IF (ABS(YNOW(L)).NE.ZERO) THEN + YPNORM = MAX(YPNORM,ABS(YPNOW(L))/WORK(PRWT-1+L)) + END IF + 80 CONTINUE + TAU = TOLR**EXPON + IF (H*YPNORM.GT.TAU) H = TAU/YPNORM + HMIN = MAX(TINY,TOOSML*MAX(ABS(TSTRT),ABS(TND))) + H = DIR*MAX(H,HMIN) + PHASE1 = .FALSE. + END IF +C + ELSE +C +C Continuation call +C + IF (LAST) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A,D13.5,A/A/A)') + &' ** You have already reached TEND ( = ', TND, ').', + &' ** To integrate further with the same problem you must ', + &' ** call the routine RESET with a new value of TEND.' + GO TO 180 + END IF + END IF +C +C Begin computation of a step here. +C + FAILED = .FALSE. +C + 100 CONTINUE + H = SIGN(ABS(H),DIR) +C +C Reduce the step size if necessary so that the code will not step +C past TND. "Look ahead" to prevent unnecessarily small step sizes. + LAST = DIR*((T+H)-TND) .GE. ZERO + IF (LAST) THEN + H = TND - T + ELSE IF (DIR*((T+TWO*H)-TND).GE.ZERO) THEN + H = (TND-T)/TWO + END IF +C +C When the integrator is at T and attempts a step of H, the function +C defining the differential equations will be evaluated at a number of +C arguments between T and T+H. If H is too small, these arguments cannot +C be clearly distinguished in the precision available. +C + HMIN = MAX(TINY,TOOSML*MAX(ABS(T),ABS(T+H))) + IF (ABS(H).LT.HMIN) THEN + IER = 5 + NREC = 3 + WRITE (REC,'(A/A,D13.5,A,D13.5/A)') + &' ** In order to satisfy your error requirements CT would ', + &' ** have to use a step size of ',H,' at TNOW = ',T, + &' ** This is too small for the machine precision.' + GO TO 180 + END IF +C +C Monitor the impact of output on the efficiency of the integration. +C + IF (CHKEFF) THEN + NTEND = NTEND + 1 + IF (NTEND.GE.100 .AND. NTEND.GE.OKSTP/3) THEN + IER = 2 + NREC = 6 + WRITE (REC,'(A/A/A/A/A/A)') + &' ** More than 100 output points have been obtained by ', + &' ** integrating to TEND. They have been sufficiently close ', + &' ** to one another that the efficiency of the integration has ', + &' ** been degraded. It would probably be (much) more efficient ', + &' ** to obtain output by interpolating with INTRP (after ', + &' ** changing to METHOD=2 if you are using METHOD = 3).' + NTEND = 0 + GO TO 180 + END IF + END IF +C +C Check for stiffness and for too much work. Stiffness can be +C checked only after a successful step. +C + IF (.NOT.FAILED) THEN +C +C Check for too much work. + TOOMCH = NFCN .GT. MAXFCN + IF (TOOMCH) THEN + IER = 3 + NREC = 3 + WRITE (REC,'(A,I6,A/A/A)') + &' ** Approximately ',MAXFCN,' function evaluations have been ', + &' ** used to compute the solution since the integration ', + &' ** started or since this message was last printed.' +C +C After this warning message, NFCN is reset to permit the integration +C to continue. The total number of function evaluations in the primary +C integration is SVNFCN + NFCN. + SVNFCN = SVNFCN + NFCN + NFCN = 0 + END IF +C +C Check for stiffness. NREC is passed on to STIFF because when +C TOOMCH = .TRUE. and stiffness is diagnosed, the message about too +C much work is augmented inside STIFF to explain that it is due to +C stiffness. + CALL STIFF(F,HAVG,JFLSTP,TOOMCH,MAXFCN,WORK,IER,NREC) +C + IF (IER.NE.1) GO TO 180 + END IF +C +C Take a step. Whilst finding an on-scale H (PHASE2 = .TRUE.), the input +C value of H might be reduced (repeatedly), but it will not be reduced +C below HMIN. The local error is estimated, a weight vector is formed, +C and a weighted maximum norm, ERR, of the local error is returned. +C The variable MAIN is input as .TRUE. to tell STEP that this is the +C primary, or "main", integration. +C +C H resides in the common block /RKCOM2/ which is used by both CT and STEP; +C since it may be changed inside STEP, a local copy is made to ensure +C portability of the code. +C + MAIN = .TRUE. + HTRY = H + CALL STEP(F,NEQN,T,WORK(PRY),WORK(PRYP),WORK(PRSTGS),TOLR,HTRY, + & WORK(PRWT),WORK(YNEW),WORK(PRERST),ERR,MAIN,HMIN, + & WORK(PRTHRS),PHASE2) + H = HTRY +C +C Compare the norm of the local error to the tolerance. +C + IF (ERR.GT.TOLR) THEN +C +C Failed step. Reduce the step size and try again. +C +C First step: Terminate PHASE3 of the search for an on-scale step size. +C The step size is not on scale, so ERR may not be accurate; +C reduce H by a fixed factor. Failed attempts to take the +C first step are not counted. +C Later step: Use ERR to compute an "optimal" reduction of H. More than +C one failure indicates a difficulty with the problem and an +C ERR that may not be accurate, so reduce H by a fixed factor. +C + IF (FIRST) THEN + PHASE3 = .FALSE. + ALPHA = RS1 + ELSE + FLSTP = FLSTP + 1 + JFLSTP = JFLSTP + 1 + IF (FAILED) THEN + ALPHA = RS1 + ELSE + ALPHA = SAFETY*(TOLR/ERR)**EXPON + ALPHA = MAX(ALPHA,RS1) + END IF + END IF + H = ALPHA*H + FAILED = .TRUE. + GO TO 100 + END IF +C +C Successful step. +C +C Predict a step size appropriate for the next step. After the first +C step the prediction can be refined using an idea of H.A. Watts that +C takes account of how well the prediction worked on the previous step. + BETA = (ERR/TOLR)**EXPON + IF (.NOT.FIRST) THEN + TEMP1 = (ERR**EXPON)/H + TEMP2 = (ERROLD**EXPON)/HOLD + IF (TEMP1.LT.TEMP2*HUNDRD .AND. TEMP2.LT.TEMP1*HUNDRD) THEN + BETA = BETA*(TEMP1/TEMP2) + END IF + END IF + ALPHA = RS3 + IF (SAFETY.LT.BETA*ALPHA) ALPHA = SAFETY/BETA +C +C On the first step a search is made for an on-scale step size. PHASE2 +C of the scheme comes to an end here because a step size has been found +C that is both successful and has a credible local error estimate. Except +C in the special case that the first step is also the last, the step is +C repeated in PHASE3 as long as an increase greater than RS2 appears +C possible. An increase as big as RS3 is permitted. A step failure +C terminates PHASE3. +C + IF (FIRST) THEN + PHASE2 = .FALSE. + PHASE3 = PHASE3 .AND. .NOT. LAST .AND. (ALPHA.GT.RS2) + IF (PHASE3) THEN + H = ALPHA*H + GO TO 100 + END IF + END IF +C +C After getting on scale, step size changes are more restricted. + ALPHA = MIN(ALPHA,RS) + IF (FAILED) ALPHA = MIN(ALPHA,ONE) + ALPHA = MAX(ALPHA,RS1) + HOLD = H + H = ALPHA*H +C +C For the diagnosis of stiffness, an average accepted step size, HAVG, +C must be computed and SAVEd. + IF (FIRST) THEN + HAVG = HOLD + ELSE + HAVG = PT9*HAVG + PT1*HOLD + END IF +C + FIRST = .FALSE. + ERROLD = ERR + TOLD = T +C +C Take care that T is set to precisely TND when the end of the +C integration is reached. + IF (LAST) THEN + T = TND + ELSE + T = T + HOLD + END IF +C +C Increment counter on accepted steps. Note that successful steps +C that are repeated whilst getting on scale are not counted. + OKSTP = OKSTP + 1 +C +C Advance the current solution and its derivative. (Stored in WORK(*) +C with the first location being PRY and PRYP, respectively.) Update the +C previous solution and its derivative. (Stored in WORK(*) with the first +C location being PRYOLD and YPOLD, respectively.) Note that the previous +C derivative will overwrite YNEW(*). +C + DO 120 L = 1, NEQN + WORK(PRYOLD-1+L) = WORK(PRY-1+L) + WORK(PRY-1+L) = WORK(YNEW-1+L) + WORK(YPOLD-1+L) = WORK(PRYP-1+L) + 120 CONTINUE +C + IF (FSAL) THEN +C +C When FSAL = .TRUE., YP(*) is the last stage of the step. + POINT = PRSTGS + (LSTSTG-1)*NEQN + DO 140 L = 1, NEQN + WORK(PRYP-1+L) = WORK(POINT-1+L) + 140 CONTINUE + ELSE +C +C Call F to evaluate YP(*). + CALL F(T,WORK(PRY),WORK(PRYP)) + NFCN = NFCN + 1 + END IF +C +C If global error assessment is desired, advance the secondary +C integration from TOLD to T. +C + IF (ERASON) THEN + CALL TRUERR(F,NEQN,WORK(PRY),TOLR,WORK(PRWT),WORK(PRZY), + & WORK(PRZYP),WORK(PRZERR),WORK(PRZYNU),WORK(PRZERS), + & WORK(PRZSTG),IER) + IF (IER.EQ.6) THEN +C +C The global error estimating procedure has broken down. Treat it as a +C failed step. The solution and derivative are reset to their values at +C the beginning of the step since the last valid error assessment refers +C to them. + OKSTP = OKSTP - 1 + ERASFL = .TRUE. + LAST = .FALSE. + T = TOLD + H = HOLD + DO 160 L = 1, NEQN + WORK(PRY-1+L) = WORK(PRYOLD-1+L) + WORK(PRYP-1+L) = WORK(YPOLD-1+L) + 160 CONTINUE + IF (OKSTP.GT.1) THEN + NREC = 2 + WRITE (REC,'(A/A,D13.5,A)') + &' ** The global error assessment may not be reliable for T past ', + &' ** TNOW = ',T,'. The integration is being terminated.' + ELSE + NREC = 2 + WRITE (REC,'(A/A)') + &' ** The global error assessment algorithm failed at the start', + &' ** the integration. The integration is being terminated.' + END IF + GO TO 180 + END IF + END IF +C +C +C Exit point for CT +C + 180 CONTINUE +C +C Set the output variables and flag that interpolation is permitted +C + IF (IER.LT.911) THEN + TNOW = T + LAST = TNOW .EQ. TND + CHKEFF = LAST + DO 200 L = 1, NEQN + YNOW(L) = WORK(PRY-1+L) + YPNOW(L) = WORK(PRYP-1+L) + 200 CONTINUE + IF (IER.EQ.1) THEN + STATE = MINUS2 + CALL RKSIT(TELL,'INTRP',STATE) + END IF + END IF +C +C Call RKMSG to report what happened and set CFLAG. +C + CALL RKMSG(IER,SRNAME,NREC,CFLAG) +C + RETURN + END + SUBROUTINE INTRP(TWANT,REQEST,NWANT,YWANT,YPWANT,F,WORK,WRKINT, + & LENINT) +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C +C If you are not familiar with the code INTRP and how it is used in +C conjunction with CT to solve initial value problems, you should study the +C document file rksuite.doc carefully before attempting to use the code. The +C following "Brief Reminder" is intended only to remind you of the meaning, +C type, and size requirements of the arguments. +C +C When integrating with METHOD = 1 or 2, answers may be obtained inexpensively +C between steps by interpolation. INTRP is called after a step by CT from a +C previous value of T, called TOLD below, to the current value of T to get +C an answer at TWANT. You can specify any value of TWANT you wish, but +C specifying a value outside the interval [TOLD,T] is likely to yield +C answers with unsatisfactory accuracy. +C +C INPUT VARIABLE +C +C TWANT - DOUBLE PRECISION +C The value of the independent variable where a solution +C is desired. +C +C The interpolant is to be evaluated at TWANT to approximate the solution +C and/or its first derivative there. There are three cases: +C +C INPUT VARIABLE +C +C REQEST - CHARACTER*(*) +C Only the first character of REQEST is significant. +C REQEST(1:1) = `S' or `s'- compute approximate `S'olution +C only. +C = `D' or `d'- compute approximate first +C `D'erivative of the solution only. +C = `B' or `b'- compute `B'oth approximate solution +C and first derivative. +C Constraint: REQEST(1:1) must be `S',`s',`D',`d',`B' or `b'. +C +C If you intend to interpolate at many points, you should arrange for the +C the interesting components to be the first ones because the code +C approximates only the first NWANT components. +C +C INPUT VARIABLE +C +C NWANT - INTEGER +C Only the first NWANT components of the answer are to be +C computed. +C Constraint: NEQ >= NWANT >= 1 +C +C OUTPUT VARIABLES +C +C YWANT(*) - DOUBLE PRECISION array of length NWANT +C Approximation to the first NWANT components of the true +C solution at TWANT when REQESTed. +C YPWANT(*) - DOUBLE PRECISION array of length NWANT +C Approximation to the first NWANT components of the first +C derivative of the true solution at TWANT when REQESTed. +C +C NAME DECLARED IN AN EXTERNAL STATEMENT IN THE PROGRAM CALLING INTRP: +C +C F - name of the subroutine for evaluating the differential +C equations as provided to CT. +C +C WORKSPACE +C +C WORK(*) - DOUBLE PRECISION array as used in SETUP and CT +C Do not alter the contents of this array. +C +C WRKINT(*) - DOUBLE PRECISION array of length LENINT +C Do not alter the contents of this array. +C +C LENINT - INTEGER +C Length of WRKINT. If +C METHOD = 1, LENINT must be at least 1 +C = 2, LENINT must be at least NEQ+MAX(NEQ,5*NWANT) +C = 3--CANNOT BE USED WITH THIS SUBROUTINE +C +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C .. Scalar Arguments .. + DOUBLE PRECISION TWANT + INTEGER LENINT, NWANT + CHARACTER*(*) REQEST +C .. Array Arguments .. + DOUBLE PRECISION WORK(*), WRKINT(*), YPWANT(*), YWANT(*) +C .. Subroutine Arguments .. + EXTERNAL F +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block for General Workspace Pointers .. + INTEGER PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + COMMON /RKCOM3/ PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + SAVE /RKCOM3/ +C .. Common Block to hold Formula Definitions .. + DOUBLE PRECISION A(13,13), B(13), C(13), BHAT(13), R(11,6), + & E(7) + INTEGER PTR(13), NSTAGE, METHD, MINTP + LOGICAL INTP + COMMON /RKCOM4/ A, B, C, BHAT, R, E, PTR, NSTAGE, METHD, + & MINTP, INTP + SAVE /RKCOM4/ +C .. Common Block for Integrator Options .. + LOGICAL MSG, UTASK + COMMON /RKCOM8/ MSG, UTASK + SAVE /RKCOM8/ +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ +C .. Parameters .. + CHARACTER*6 SRNAME + PARAMETER (SRNAME='INTRP') + LOGICAL ASK + INTEGER PLUS1, MINUS1, MINUS2 + PARAMETER (ASK=.TRUE.,PLUS1=1,MINUS1=-1,MINUS2=-2) +C .. Local Scalars .. + INTEGER FLAG, ICHK, IER, NREC, NWNTSV, STARTP, STATE, + & STATE1 + LOGICAL ININTP, LEGALR + CHARACTER REQST1 +C .. External Subroutines .. + EXTERNAL EVALI, FORMI, RKMSG, RKSIT +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Save statement .. + SAVE NWNTSV, ININTP, STARTP +C .. Data statements .. + DATA NWNTSV/MINUS1/ +C .. Executable Statements .. +C + IER = 1 + NREC = 0 +C +C Is it permissible to call INTRP? +C + CALL RKSIT(ASK,'CT',STATE) + IF (STATE.EQ.911) THEN + IER = 912 + NREC = 1 + WRITE (REC,'(A)') + &' ** A catastrophic error has already been detected elsewhere.' + GO TO 20 + END IF + IF (UTASK) THEN + CALL RKSIT(ASK,'UT',STATE1) + IF (STATE1.NE.MINUS2) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A/A)') + &' ** You have called INTRP after you specified to SETUP ', + &' ** that you were going to use UT. This is not permitted.' + GO TO 20 + END IF + END IF + IF (STATE.EQ.MINUS1) THEN + IER = 911 + NREC = 1 + WRITE (REC,'(A)') + &' ** You have not called CT, so you cannot use INTRP.' + GO TO 20 + END IF + IF (STATE.GT.PLUS1) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A/A)') + &' ** CT has returned with a flag value greater than 1.', + &' ** You cannot call INTRP in this circumstance.' + GO TO 20 + END IF +C +C Check input +C + REQST1 = REQEST(1:1) + LEGALR = REQST1 .EQ. 'S' .OR. REQST1 .EQ. 's' .OR. + & REQST1 .EQ. 'D' .OR. REQST1 .EQ. 'd' .OR. + & REQST1 .EQ. 'B' .OR. REQST1 .EQ. 'b' + IF (.NOT.LEGALR) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A/A,A,A/A)') + &' ** You have set the first character of ', + &' ** REQEST to be ''',REQST1,'''. It must be one of ', + &' ** ''S'',''s'',''D'',''d'',''B'' or ''b''.' + GO TO 20 + END IF +C + IF (NWANT.GT.NEQN) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A,I6,A/A,I6,A/A)') + &' ** You have specified the value of NWANT to be ',NWANT,'. This', + &' ** is greater than ',NEQN,', which is the number of equations ', + &' ** in the system being integrated.' + GO TO 20 + ELSE IF (NWANT.LT.1) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A,I6,A/A/A)') + &' ** You have specified the value of NWANT to be ',NWANT,', but ', + &' ** this is less than 1. You cannot interpolate a zero or ', + &' ** negative number of components.' + GO TO 20 + END IF +C + IF (METHD.EQ.1) THEN + IF (LENINT.LT.1) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A,I6,A/A)') + &' ** You have specified LENINT to be ',LENINT,'.', + &' ** This is too small. LENINT must be at least 1.' + GO TO 20 + END IF + STARTP = 1 + ELSE IF (METHD.EQ.2) THEN + ICHK = NEQN + MAX(NEQN,5*NWANT) + IF (LENINT.LT.ICHK) THEN + IER = 911 + NREC = 3 + WRITE (REC,'(A,I6,A/A/A,I6,A)') + &' ** You have specified LENINT to be ',LENINT,'. This is too', + &' ** small. NINT must be at least NEQ + MAX(NEQ, 5*NWANT) ', + &' ** which is ', ICHK,'.' + GO TO 20 + END IF + STARTP = NEQN + 1 + ELSE IF (METHD.EQ.3) THEN + IER = 911 + NREC = 5 + WRITE (REC,'(A/A/A/A/A)') + &' ** You have been using CT with METHOD = 3 to integrate your ', + &' ** equations. You have just called INTRP, but interpolation ', + &' ** is not available for this METHOD. Either use METHOD = 2, ', + &' ** for which interpolation is available, or use RESET to make', + &' ** CT step exactly to the points where you want output.' + GO TO 20 + END IF +C +C Has the interpolant been initialised for this step? +C + CALL RKSIT(ASK,SRNAME,STATE) + ININTP = STATE .NE. MINUS2 +C +C Some initialization must be done before interpolation is possible. +C To reduce the overhead, the interpolating polynomial is formed for +C the first NWANT components. In the unusual circumstance that NWANT +C is changed while still interpolating within the span of the current +C step, the scheme must be reinitialized to accomodate the additional +C components. +C + IF (.NOT.ININTP .OR. NWANT.NE.NWNTSV) THEN +C +C At present the derivative of the solution at the previous step, YPOLD(*), +C is stored in the scratch array area starting at PRSCR. In the case of +C METHD = 1 we can overwrite the stages. +C + IF (METHD.EQ.1) THEN + CALL FORMI(F,NEQN,NWANT,WORK(PRY),WORK(PRYP),WORK(PRYOLD), + & WORK(PRSCR),WORK(PRSTGS),.NOT.ININTP, + & WORK(PRSTGS),WORK(PRSTGS)) + ELSE + CALL FORMI(F,NEQN,NWANT,WORK(PRY),WORK(PRYP),WORK(PRYOLD), + & WORK(PRSCR),WORK(PRSTGS),.NOT.ININTP,WRKINT, + & WRKINT(STARTP)) + END IF +C +C Set markers to show that interpolation has been initialized for +C NWANT components. + NWNTSV = NWANT + ININTP = .TRUE. + END IF +C +C The actual evaluation of the interpolating polynomial and/or its first +C derivative is done in EVALI. +C + IF (METHD.EQ.1) THEN + CALL EVALI(WORK(PRY),WORK(PRYP),WORK(PRSTGS),TWANT,REQEST, + & NWANT,YWANT,YPWANT) + ELSE + CALL EVALI(WORK(PRY),WORK(PRYP),WRKINT(STARTP),TWANT,REQEST, + & NWANT,YWANT,YPWANT) + END IF +C + 20 CONTINUE +C + CALL RKMSG(IER,SRNAME,NREC,FLAG) +C + RETURN + END + SUBROUTINE RESET(TENDNU) +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C +C If you are not familiar with the code RESET and how it is used in +C conjunction with CT to solve initial value problems, you should study the +C document file rksuite.doc carefully before attempting to use the code. The +C following "Brief Reminder" is intended only to remind you of the meaning, +C type, and size requirements of the arguments. +C +C The integration using CT proceeds from TSTART in the direction of TEND, and +C is now at TNOW. To reset TEND to a new value TENDNU, just call RESET with +C TENDNU as the argument. You must continue integrating in the same +C direction, so the sign of (TENDNU - TNOW) must be the same as the sign of +C (TEND - TSTART). To change direction you must restart by a call to SETUP. +C +C INPUT VARIABLE +C +C TENDNU - DOUBLE PRECISION +C The new value of TEND. +C Constraint: TENDNU and TNOW must be clearly distinguishable +C in the precision used. The sign of (TENDNU - TNOW) must be +C the same as the sign of (TEND - TSTART). +C +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C .. Scalar Arguments .. + DOUBLE PRECISION TENDNU +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Common Block for Integrator Options .. + LOGICAL MSG, UTASK + COMMON /RKCOM8/ MSG, UTASK + SAVE /RKCOM8/ +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ +C .. Parameters .. + CHARACTER*6 SRNAME + PARAMETER (SRNAME='RESET') + LOGICAL ASK + INTEGER MINUS1, MINUS2 + PARAMETER (ASK=.TRUE.,MINUS1=-1,MINUS2=-2) + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +C .. Local Scalars .. + DOUBLE PRECISION HMIN, TDIFF + INTEGER FLAG, IER, NREC, STATE, STATE1 +C .. External Subroutines .. + EXTERNAL RKMSG, RKSIT +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. Executable Statements .. + IER = 1 + NREC = 0 +C +C Is it permissible to call RESET? +C + CALL RKSIT(ASK,'CT',STATE) + IF (STATE.EQ.911) THEN + IER = 912 + NREC = 1 + WRITE (REC,'(A)') + &' ** A catastrophic error has already been detected elsewhere.' + GO TO 20 + END IF + IF (UTASK) THEN + CALL RKSIT(ASK,'UT',STATE1) + IF (STATE1.NE.MINUS2) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A/A)') + &' ** You have called RESET after you specified to SETUP that ', + &' ** you were going to use UT. This is not permitted.' + GO TO 20 + END IF + END IF + IF (STATE.EQ.MINUS1) THEN + IER = 911 + NREC = 1 + WRITE (REC,'(A)') + &' ** You have not called CT, so you cannot use RESET.' + GO TO 20 + END IF + IF (STATE.EQ.5 .OR. STATE.EQ.6) THEN + IER = 911 + NREC = 2 + WRITE (REC,'(A,I1,A/A)') + &' ** CT has returned with CFLAG = ',STATE,'.', + &' ** You cannot call RESET in this circumstance.' + GO TO 20 + END IF +C +C Check value of TENDNU +C + IF (DIR.GT.ZERO .AND. TENDNU.LE.T) THEN + IER = 911 + NREC = 4 + WRITE (REC,'(A/A,D13.5/A,D13.5,A/A)') + &' ** Integration is proceeding in the positive direction. The ', + &' ** current value for the independent variable is ',T, + &' ** and you have set TENDNU = ',TENDNU,'. TENDNU must be ', + &' ** greater than T.' + ELSE IF (DIR.LT.ZERO .AND. TENDNU.GE.T) THEN + IER = 911 + NREC = 4 + WRITE (REC,'(A/A,D13.5/A,D13.5,A/A)') + &' ** Integration is proceeding in the negative direction. The ', + &' ** current value for the independent variable is ',T, + &' ** and you have set TENDNU = ',TENDNU,'. TENDNU must be ', + &' ** less than T.' + ELSE + HMIN = MAX(TINY,TOOSML*MAX(ABS(T),ABS(TENDNU))) + TDIFF = ABS(TENDNU-T) + IF (TDIFF.LT.HMIN) THEN + IER = 911 + NREC = 4 + WRITE (REC,'(A,D13.5,A/A,D13.5,A/A/A,D13.5,A)') + &' ** The current value of the independent variable T is ',T,'.', + &' ** The TENDNU you supplied has ABS(TENDNU-T) = ',TDIFF,'.', + &' ** For the METHOD and the precision of the computer being ', + &' ** used, this difference must be at least ',HMIN,'.' + END IF + END IF + IF (IER.EQ.911) GO TO 20 +C + TND = TENDNU + LAST = .FALSE. +C + 20 CONTINUE +C + CALL RKMSG(IER,SRNAME,NREC,FLAG) +C + RETURN + END + SUBROUTINE MCONST(METHOD) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: Sets machine-dependent global quantities +C +C Common: Initializes: /RKCOM7/ OUTCH, MCHEPS, DWARF, RNDOFF, +C SQRRMC, CUBRMC, TINY +C Reads: none +C Alters: none +C +C Comments: +C ========= +C OUTCH, MCHEPS, DWARF are pure environmental parameters with values +C obtained from a call to ENVIRN. The other quantities set depend on +C the environmental parameters, the implementation, and, possibly, +C METHOD. At present the METHODs implemented in the RK suite do not +C influence the values of these quantities. +C OUTCH - Standard output channel +C MCHEPS - Largest positive number such that 1.0D0 + MCHEPS = 1.0D0 +C DWARF - Smallest positive number +C RNDOFF - 10 times MCHEPS +C SQRRMC - Square root of MCHEPS +C CUBRMC - Cube root of MCHEPS +C TINY - Square root of DWARF +C +C .. Scalar Arguments .. + INTEGER METHOD +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Parameters .. + DOUBLE PRECISION TEN, THIRD + PARAMETER (TEN=10.0D+0,THIRD=1.0D+0/3.0D+0) +C .. External Subroutines .. + EXTERNAL ENVIRN +C .. Intrinsic Functions .. + INTRINSIC SQRT +C .. Executable Statements .. +C + CALL ENVIRN(OUTCH,MCHEPS,DWARF) +C + RNDOFF = TEN*MCHEPS + SQRRMC = SQRT(MCHEPS) + CUBRMC = MCHEPS**THIRD + TINY = SQRT(DWARF) +C + RETURN + END + SUBROUTINE ENVIRN(OUTCH,MCHEPS,DWARF) +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C +C The RK suite requires some environmental parameters that are provided by +C this subroutine. The values provided with the distribution codes are those +C appropriate to the IEEE standard. They must be altered, if necessary, to +C those appropriate to the computing system you are using before calling the +C codes of the suite. +C +C ================================================================ +C ================================================================ +C TO MAKE SURE THAT THESE MACHINE AND INSTALLATION DEPENDENT +C QUANTITIES ARE SPECIFIED PROPERLY, THE DISTRIBUTION VERSION +C WRITES A MESSAGE ABOUT THE MATTER TO THE STANDARD OUTPUT CHANNEL +C AND TERMINATES THE RUN. THE VALUES PROVIDED IN THE DISTRIBUTION +C VERSION SHOULD BE ALTERED, IF NECESSARY, AND THE "WRITE" AND +C "STOP" STATEMENTS COMMENTED OUT. +C ================================================================ +C ================================================================ +C +C OUTPUT VARIABLES +C +C OUTCH - INTEGER +C Standard output channel +C MCHEPS - DOUBLE PRECISION +C MCHEPS is the largest positive number such that +C 1.0D0 + MCHEPS = 1.0D0. +C DWARF - DOUBLE PRECISION +C DWARF is the smallest positive number. +C +C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +C +C .. Scalar Arguments .. + INTEGER OUTCH + DOUBLE PRECISION DWARF, MCHEPS +C .. Executable Statements .. +C +C The following six statements are to be Commented out after verification that +C the machine and installation dependent quantities are specified correctly. +C If you pass copies of RKSUITE on to others, please give them the whole +C distribution version of RKSUITE, and in particular, give them a version +C of ENVIRN that does not have the following six statements Commented out. + WRITE(*,*) ' Before using RKSUITE, you must verify that the ' + WRITE(*,*) ' machine- and installation-dependent quantities ' + WRITE(*,*) ' specified in the subroutine ENVIRN are correct, ' + WRITE(*,*) ' and then Comment these WRITE statements and the ' + WRITE(*,*) ' STOP statement out of ENVIRN. ' + STOP +C +C The following values are appropriate to IEEE arithmetic with the typical +C standard output channel. +C + OUTCH = 6 + MCHEPS = 1.11D-16 + DWARF = 2.23D-308 +C +C------------------------------------------------------------------------------ +C If you have the routines D1MACH and I1MACH on your system, you could +C replace the preceding statements by the following ones to obtain the +C appropriate machine dependent numbers. The routines D1MACH and I1MACH +C are public domain software. They are available from NETLIB. +C .. Scalar Arguments .. +C INTEGER OUTCH +C DOUBLE PRECISION DWARF, MCHEPS +C .. External Functions .. +C INTEGER I1MACH +C DOUBLE PRECISION D1MACH +C .. Executable Statements .. +C +C OUTCH = I1MACH(2) +C MCHEPS = D1MACH(3) +C DWARF = D1MACH(1) +C +C If you have the NAG Fortran Library available on your system, you could +C replace the preceding statements by the following ones to obtain the +C appropriate machine dependent numbers. +C +C .. Scalar Arguments .. +C INTEGER OUTCH +C DOUBLE PRECISION DWARF, MCHEPS +C .. External Functions .. +C DOUBLE PRECISION X02AJF, X02AMF +C .. Executable Statements .. +C +C CALL X04AAF(0,OUTCH) +C MCHEPS = X02AJF() +C DWARF = X02AMF() +C +C If you have the IMSL MATH/LIBRARY available on your system, you could +C replace the preceding statements by the following ones to obtain the +C appropriate machine dependent numbers. +C +C .. Scalar Arguments .. +C INTEGER OUTCH +C DOUBLE PRECISION DWARF, MCHEPS +C .. External Functions .. +C DOUBLE PRECISION DMACH +C .. Executable Statements .. +C +C CALL UMACH(2,OUTCH) +C MCHEPS = DMACH(4) +C DWARF = DMACH(1) +C------------------------------------------------------------------------------ +C + RETURN + END + SUBROUTINE CONST(METHOD,VECSTG,REQSTG,LINTPL) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +************************************************* +C +C Purpose: Set formula definitions and formula characteristics for +C selected method. Return storage requirements for the +C selected method. +C +C Input: METHOD +C Output: VECSTG, REQSTG, LINTPL +C +C Common: Initializes: /RKCOM4/ A(*,*), B(*), C(*), BHAT(*), R(*), +C E(*), PTR(*), NSTAGE, METHD, INTP, MINTP +C /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, +C TANANG, RS, RS1, RS2, RS3, RS4, ORDER, +C LSTSTG, MAXTRY, NSEC, FSAL +C Reads: /RKCOM7/ RNDOFF +C Alters: none +C +C Comments: +C ========= +C Runge-Kutta formula pairs are described by a set of coefficients +C and by the setting of a number of parameters that describe the +C characteristics of the pair. The input variable METHD indicates +C which of the three pairs available is to be set. In the case of +C METHD = 2 additional coefficients are defined that make interpolation +C of the results possible and provide an additional error estimator. +C VECSTG is the number of columns of workspace required to compute the +C stages of a METHD. For interpolation purposes the routine returns via +C COMMON the logical variable INTP indicating whether interpolation is +C possible and via the call list: +C REQSTG - whether the stages are required to form the +C interpolant (set .FALSE. if INTP=.FALSE.) +C LINTPL - the number of extra columns of storage required for use +C with UT (set 0 if INTP=.FALSE.) +C +C Quantities set in common blocks: +C METHD - copy of METHOD +C A, B, C, BHAT - coefficients of the selected method +C R - extra coefficents for interpolation with METHD = 2 +C E - extra coefficients for additional local error estimate +C with METHD = 2 +C PTR - vector of pointers indicating how individual stages are to +C be stored. With it zero coefficients of the formulas can +C be exploited to reduce the storage required +C NSTAGE - number of stages for the specified METHD +C INTP - indicates whether there is an associated interpolant +C (depending on the method, the user may have to supply +C extra workspace) +C MINTP - the degree of the interpolating polynomial, if one exists +C FSAL - indicates whether the last stage of a step can be used as +C the first stage of the following step +C LSTSTG - pointer to location of last stage for use with FSAL=.TRUE. +C ORDER - the lower order of the pair of Runge-Kutta formulas that +C constitute a METHD +C TANANG, +C STBRAD - the stability region of the formula used to advance +C the integration is approximated by a sector in the left half +C complex plane. TANANG is the tangent of the interior angle +C of the sector and STBRAD is the radius of the sector. +C COST - cost of a successful step in function evaluations +C MAXTRY - limit on the number of iterations in the stiffness check. As +C set, no more than 24 function evaluations are made in the check. +C NSEC - each step of size H in the primary integration corresponds to +C NSEC steps of size H/NSEC in the secondary integration when +C global error assessment is done. +C EXPON - used to adjust the step size; this code implements an error +C per step control for which EXPON = 1/(ORDER + 1). +C SAFETY - quantity used in selecting the step size +C TOOSML - quantity used to determine when a step size is too small for +C the precision available +C RS, RS1, +C RS2, RS3, +C RS4 - quantities used in determining the maximum and minimum change +C change in step size (set independently of METHD) +C +C Further comments on SAFETY: +C ============================ +C The code estimates the largest step size that will yield the specified +C accuracy. About half the time this step size would result in a local +C error that is a little too large, and the step would be rejected. For +C this reason a SAFETY factor is used to reduce the "optimal" value to one +C more likely to succeed. Unfortunately, there is some art in choosing this +C value. The more expensive a failed step, the smaller one is inclined to +C take this factor. However, a small factor means that if the prediction were +C good, more accuracy than desired would be obtained and the behavior of the +C error would then be irregular. The more stringent the tolerance, the better +C the prediction, except near limiting precision. Thus the general range of +C tolerances expected influences the choice of SAFETY. +C +C .. Scalar Arguments .. + INTEGER LINTPL, METHOD, VECSTG + LOGICAL REQSTG +C .. Common Block to hold Formula Definitions .. + DOUBLE PRECISION A(13,13), B(13), C(13), BHAT(13), R(11,6), + & E(7) + INTEGER PTR(13), NSTAGE, METHD, MINTP + LOGICAL INTP + COMMON /RKCOM4/ A, B, C, BHAT, R, E, PTR, NSTAGE, METHD, + & MINTP, INTP + SAVE /RKCOM4/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO, TWO, FIFTY, FIVEPC + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0,TWO=2.0D+0,FIFTY=50.D+0, + & FIVEPC=0.05D+0) +C .. Local Scalars .. + DOUBLE PRECISION CDIFF, DIFF + INTEGER I, J +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN +C .. Executable Statements .. +C + METHD = METHOD +C + GO TO (20,40,100) METHD +C +C METHD = 1. +C This pair is from "A 3(2) Pair of Runge-Kutta Formulas" by P. Bogacki +C and L.F. Shampine, Appl. Math. Lett., 2, pp. 321-325, 1989. The authors +C are grateful to P. Bogacki for his assistance in implementing the pair. +C + 20 CONTINUE + NSTAGE = 4 + FSAL = .TRUE. + ORDER = 2 + TANANG = 8.9D0 + STBRAD = 2.3D0 + SAFETY = 0.8D0 + INTP = .TRUE. + MINTP = 3 + REQSTG = .FALSE. + LINTPL = 2 + NSEC = 3 +C + PTR(1) = 0 + PTR(2) = 1 + PTR(3) = 2 + PTR(4) = 3 +C + A(2,1) = 1.D0/2.D0 + A(3,1) = 0.D0 + A(3,2) = 3.D0/4.D0 + A(4,1) = 2.D0/9.D0 + A(4,2) = 1.D0/3.D0 + A(4,3) = 4.D0/9.D0 +C +C The coefficients BHAT(*) refer to the formula used to advance the +C integration, here the one of order 3. The coefficients B(*) refer +C to the other formula, here the one of order 2. For this pair, BHAT(*) +C is not needed since FSAL = .TRUE. +C + B(1) = 7.D0/24.D0 + B(2) = 1.D0/4.D0 + B(3) = 1.D0/3.D0 + B(4) = 1.D0/8.D0 +C + C(1) = 0.D0 + C(2) = 1.D0/2.D0 + C(3) = 3.D0/4.D0 + C(4) = 1.D0 +C + GO TO 120 +C +C METHD = 2 +C This pair is from "An Efficient Runge-Kutta (4,5) Pair" by P. Bogacki +C and L.F. Shampine, Rept. 89-20, Math. Dept., Southern Methodist +C University, Dallas, Texas, USA, 1989. The authors are grateful to +C P. Bogacki for his assistance in implementing the pair. Shampine and +C Bogacki subsequently modified the formula to enhance the reliability of +C the pair. The original fourth order formula is used in an estimate of +C the local error. If the step fails, the computation is broken off. If +C the step is acceptable, the first evaluation of the next step is done, +C i.e., the pair is implemented as FSAL and the local error of the step +C is again estimated with a fourth order formula using the additional data. +C The step must succeed with both estimators to be accepted. When the +C second estimate is formed, it is used for the subsequent adjustment of +C the step size because it is of higher quality. The two fourth order +C formulas are well matched to leading order, and only exceptionally do +C the estimators disagree -- problems with discontinuous coefficients are +C handled more reliably by using two estimators as is global error +C estimation. +C + 40 CONTINUE + NSTAGE = 8 + FSAL = .TRUE. + ORDER = 4 + TANANG = 5.2D0 + STBRAD = 3.9D0 + SAFETY = 0.8D0 + INTP = .TRUE. + REQSTG = .TRUE. + MINTP = 6 + LINTPL = 6 + NSEC = 2 +C + PTR(1) = 0 + PTR(2) = 1 + PTR(3) = 2 + PTR(4) = 3 + PTR(5) = 4 + PTR(6) = 5 + PTR(7) = 6 + PTR(8) = 7 +C + A(2,1) = 1.D0/6.D0 + A(3,1) = 2.D0/27.D0 + A(3,2) = 4.D0/27.D0 + A(4,1) = 183.D0/1372.D0 + A(4,2) = -162.D0/343.D0 + A(4,3) = 1053.D0/1372.D0 + A(5,1) = 68.D0/297.D0 + A(5,2) = -4.D0/11.D0 + A(5,3) = 42.D0/143.D0 + A(5,4) = 1960.D0/3861.D0 + A(6,1) = 597.D0/22528.D0 + A(6,2) = 81.D0/352.D0 + A(6,3) = 63099.D0/585728.D0 + A(6,4) = 58653.D0/366080.D0 + A(6,5) = 4617.D0/20480.D0 + A(7,1) = 174197.D0/959244.D0 + A(7,2) = -30942.D0/79937.D0 + A(7,3) = 8152137.D0/19744439.D0 + A(7,4) = 666106.D0/1039181.D0 + A(7,5) = -29421.D0/29068.D0 + A(7,6) = 482048.D0/414219.D0 + A(8,1) = 587.D0/8064.D0 + A(8,2) = 0.D0 + A(8,3) = 4440339.D0/15491840.D0 + A(8,4) = 24353.D0/124800.D0 + A(8,5) = 387.D0/44800.D0 + A(8,6) = 2152.D0/5985.D0 + A(8,7) = 7267.D0/94080.D0 +C +C The coefficients B(*) refer to the formula of order 4. +C + B(1) = 2479.D0/34992.D0 + B(2) = 0.D0 + B(3) = 123.D0/416.D0 + B(4) = 612941.D0/3411720.D0 + B(5) = 43.D0/1440.D0 + B(6) = 2272.D0/6561.D0 + B(7) = 79937.D0/1113912.D0 + B(8) = 3293.D0/556956.D0 +C +C The coefficients E(*) refer to an estimate of the local error based on +C the first formula of order 4. It is the difference of the fifth order +C result, here located in A(8,*), and the fourth order result. By +C construction both E(2) and E(7) are zero. +C + E(1) = -3.D0/1280.D0 + E(2) = 0.D0 + E(3) = 6561.D0/632320.D0 + E(4) = -343.D0/20800.D0 + E(5) = 243.D0/12800.D0 + E(6) = -1.D0/95.D0 + E(7) = 0.D0 +C + C(1) = 0.D0 + C(2) = 1.D0/6.D0 + C(3) = 2.D0/9.D0 + C(4) = 3.D0/7.D0 + C(5) = 2.D0/3.D0 + C(6) = 3.D0/4.D0 + C(7) = 1.D0 + C(8) = 1.D0 +C +C To do interpolation with this pair, some extra stages have to be computed. +C The following additional A(*,*) and C(*) coefficients are for this purpose. +C In addition there is an array R(*,*) that plays a role for interpolation +C analogous to that of BHAT(*) for the basic step. +C + C(9) = 1.D0/2.D0 + C(10) = 5.D0/6.D0 + C(11) = 1.D0/9.D0 +C + A(9,1) = 455.D0/6144.D0 + A(10,1) = -837888343715.D0/13176988637184.D0 + A(11,1) = 98719073263.D0/1551965184000.D0 + A(9,2) = 0.D0 + A(10,2) = 30409415.D0/52955362.D0 + A(11,2) = 1307.D0/123552.D0 + A(9,3) = 10256301.D0/35409920.D0 + A(10,3) = -48321525963.D0/759168069632.D0 + A(11,3) = 4632066559387.D0/70181753241600.D0 + A(9,4) = 2307361.D0/17971200.D0 + A(10,4) = 8530738453321.D0/197654829557760.D0 + A(11,4) = 7828594302389.D0/382182512025600.D0 + A(9,5) = -387.D0/102400.D0 + A(10,5) = 1361640523001.D0/1626788720640.D0 + A(11,5) = 40763687.D0/11070259200.D0 + A(9,6) = 73.D0/5130.D0 + A(10,6) = -13143060689.D0/38604458898.D0 + A(11,6) = 34872732407.D0/224610586200.D0 + A(9,7) = -7267.D0/215040.D0 + A(10,7) = 18700221969.D0/379584034816.D0 + A(11,7) = -2561897.D0/30105600.D0 + A(9,8) = 1.D0/32.D0 + A(10,8) = -5831595.D0/847285792.D0 + A(11,8) = 1.D0/10.D0 + A(10,9) = -5183640.D0/26477681.D0 + A(11,9) = -1.D0/10.D0 + A(11,10) = -1403317093.D0/11371610250.D0 +C + DO 60 I = 1, 11 + R(I,1) = 0.D0 + 60 CONTINUE + DO 80 I = 1, 6 + R(2,I) = 0.D0 + 80 CONTINUE + R(1,6) = -12134338393.D0/1050809760.D0 + R(1,5) = -1620741229.D0/50038560.D0 + R(1,4) = -2048058893.D0/59875200.D0 + R(1,3) = -87098480009.D0/5254048800.D0 + R(1,2) = -11513270273.D0/3502699200.D0 +C + R(3,6) = -33197340367.D0/1218433216.D0 + R(3,5) = -539868024987.D0/6092166080.D0 + R(3,4) = -39991188681.D0/374902528.D0 + R(3,3) = -69509738227.D0/1218433216.D0 + R(3,2) = -29327744613.D0/2436866432.D0 +C + R(4,6) = -284800997201.D0/19905339168.D0 + R(4,5) = -7896875450471.D0/165877826400.D0 + R(4,4) = -333945812879.D0/5671036800.D0 + R(4,3) = -16209923456237.D0/497633479200.D0 + R(4,2) = -2382590741699.D0/331755652800.D0 +C + R(5,6) = -540919.D0/741312.D0 + R(5,5) = -103626067.D0/43243200.D0 + R(5,4) = -633779.D0/211200.D0 + R(5,3) = -32406787.D0/18532800.D0 + R(5,2) = -36591193.D0/86486400.D0 +C + R(6,6) = 7157998304.D0/374350977.D0 + R(6,5) = 30405842464.D0/623918295.D0 + R(6,4) = 183022264.D0/5332635.D0 + R(6,3) = -3357024032.D0/1871754885.D0 + R(6,2) = -611586736.D0/89131185.D0 +C + R(7,6) = -138073.D0/9408.D0 + R(7,5) = -719433.D0/15680.D0 + R(7,4) = -1620541.D0/31360.D0 + R(7,3) = -385151.D0/15680.D0 + R(7,2) = -65403.D0/15680.D0 +C + R(8,6) = 1245.D0/64.D0 + R(8,5) = 3991.D0/64.D0 + R(8,4) = 4715.D0/64.D0 + R(8,3) = 2501.D0/64.D0 + R(8,2) = 149.D0/16.D0 + R(8,1) = 1.D0 +C + R(9,6) = 55.D0/3.D0 + R(9,5) = 71.D0 + R(9,4) = 103.D0 + R(9,3) = 199.D0/3.D0 + R(9,2) = 16.0D0 +C + R(10,6) = -1774004627.D0/75810735.D0 + R(10,5) = -1774004627.D0/25270245.D0 + R(10,4) = -26477681.D0/359975.D0 + R(10,3) = -11411880511.D0/379053675.D0 + R(10,2) = -423642896.D0/126351225.D0 +C + R(11,6) = 35.D0 + R(11,5) = 105.D0 + R(11,4) = 117.D0 + R(11,3) = 59.D0 + R(11,2) = 12.D0 +C + GO TO 120 +C +C METHD = 3 +C This pair is from "High Order Embedded Runge-Kutta Formulae" by P.J. +C Prince and J.R. Dormand, J. Comp. Appl. Math.,7, pp. 67-75, 1981. The +C authors are grateful to P. Prince and J. Dormand for their assistance in +C implementing the pair. +C + 100 CONTINUE + NSTAGE = 13 + FSAL = .FALSE. + ORDER = 7 + TANANG = 11.0D0 + STBRAD = 5.2D0 + SAFETY = 0.8D0 + INTP = .FALSE. + REQSTG = .FALSE. + MINTP = 0 + LINTPL = 0 + NSEC = 2 +C + PTR(1) = 0 + PTR(2) = 1 + PTR(3) = 2 + PTR(4) = 1 + PTR(5) = 3 + PTR(6) = 2 + PTR(7) = 4 + PTR(8) = 5 + PTR(9) = 6 + PTR(10) = 7 + PTR(11) = 8 + PTR(12) = 9 + PTR(13) = 1 +C + A(2,1) = 5.55555555555555555555555555556D-2 + A(3,1) = 2.08333333333333333333333333333D-2 + A(3,2) = 6.25D-2 + A(4,1) = 3.125D-2 + A(4,2) = 0.D0 + A(4,3) = 9.375D-2 + A(5,1) = 3.125D-1 + A(5,2) = 0.D0 + A(5,3) = -1.171875D0 + A(5,4) = 1.171875D0 + A(6,1) = 3.75D-2 + A(6,2) = 0.D0 + A(6,3) = 0.D0 + A(6,4) = 1.875D-1 + A(6,5) = 1.5D-1 + A(7,1) = 4.79101371111111111111111111111D-2 + A(7,2) = 0.D0 + A(7,3) = 0.0D0 + A(7,4) = 1.12248712777777777777777777778D-1 + A(7,5) = -2.55056737777777777777777777778D-2 + A(7,6) = 1.28468238888888888888888888889D-2 + A(8,1) = 1.6917989787292281181431107136D-2 + A(8,2) = 0.D0 + A(8,3) = 0.D0 + A(8,4) = 3.87848278486043169526545744159D-1 + A(8,5) = 3.59773698515003278967008896348D-2 + A(8,6) = 1.96970214215666060156715256072D-1 + A(8,7) = -1.72713852340501838761392997002D-1 + A(9,1) = 6.90957533591923006485645489846D-2 + A(9,2) = 0.D0 + A(9,3) = 0.D0 + A(9,4) = -6.34247976728854151882807874972D-1 + A(9,5) = -1.61197575224604080366876923982D-1 + A(9,6) = 1.38650309458825255419866950133D-1 + A(9,7) = 9.4092861403575626972423968413D-1 + A(9,8) = 2.11636326481943981855372117132D-1 + A(10,1) = 1.83556996839045385489806023537D-1 + A(10,2) = 0.D0 + A(10,3) = 0.D0 + A(10,4) = -2.46876808431559245274431575997D0 + A(10,5) = -2.91286887816300456388002572804D-1 + A(10,6) = -2.6473020233117375688439799466D-2 + A(10,7) = 2.84783876419280044916451825422D0 + A(10,8) = 2.81387331469849792539403641827D-1 + A(10,9) = 1.23744899863314657627030212664D-1 + A(11,1) = -1.21542481739588805916051052503D0 + A(11,2) = 0.D0 + A(11,3) = 0.D0 + A(11,4) = 1.66726086659457724322804132886D1 + A(11,5) = 9.15741828416817960595718650451D-1 + A(11,6) = -6.05660580435747094755450554309D0 + A(11,7) = -1.60035735941561781118417064101D1 + A(11,8) = 1.4849303086297662557545391898D1 + A(11,9) = -1.33715757352898493182930413962D1 + A(11,10) = 5.13418264817963793317325361166D0 + A(12,1) = 2.58860916438264283815730932232D-1 + A(12,2) = 0.D0 + A(12,3) = 0.D0 + A(12,4) = -4.77448578548920511231011750971D0 + A(12,5) = -4.3509301377703250944070041181D-1 + A(12,6) = -3.04948333207224150956051286631D0 + A(12,7) = 5.57792003993609911742367663447D0 + A(12,8) = 6.15583158986104009733868912669D0 + A(12,9) = -5.06210458673693837007740643391D0 + A(12,10) = 2.19392617318067906127491429047D0 + A(12,11) = 1.34627998659334941535726237887D-1 + A(13,1) = 8.22427599626507477963168204773D-1 + A(13,2) = 0.D0 + A(13,3) = 0.D0 + A(13,4) = -1.16586732572776642839765530355D1 + A(13,5) = -7.57622116690936195881116154088D-1 + A(13,6) = 7.13973588159581527978269282765D-1 + A(13,7) = 1.20757749868900567395661704486D1 + A(13,8) = -2.12765911392040265639082085897D0 + A(13,9) = 1.99016620704895541832807169835D0 + A(13,10) = -2.34286471544040292660294691857D-1 + A(13,11) = 1.7589857770794226507310510589D-1 + A(13,12) = 0.D0 +C +C The coefficients BHAT(*) refer to the formula used to advance the +C integration, here the one of order 8. The coefficients B(*) refer +C to the other formula, here the one of order 7. +C + BHAT(1) = 4.17474911415302462220859284685D-2 + BHAT(2) = 0.D0 + BHAT(3) = 0.D0 + BHAT(4) = 0.D0 + BHAT(5) = 0.D0 + BHAT(6) = -5.54523286112393089615218946547D-2 + BHAT(7) = 2.39312807201180097046747354249D-1 + BHAT(8) = 7.0351066940344302305804641089D-1 + BHAT(9) = -7.59759613814460929884487677085D-1 + BHAT(10) = 6.60563030922286341461378594838D-1 + BHAT(11) = 1.58187482510123335529614838601D-1 + BHAT(12) = -2.38109538752862804471863555306D-1 + BHAT(13) = 2.5D-1 +C + B(1) = 2.9553213676353496981964883112D-2 + B(2) = 0.D0 + B(3) = 0.D0 + B(4) = 0.D0 + B(5) = 0.D0 + B(6) = -8.28606276487797039766805612689D-1 + B(7) = 3.11240900051118327929913751627D-1 + B(8) = 2.46734519059988698196468570407D0 + B(9) = -2.54694165184190873912738007542D0 + B(10) = 1.44354858367677524030187495069D0 + B(11) = 7.94155958811272872713019541622D-2 + B(12) = 4.44444444444444444444444444445D-2 + B(13) = 0.D0 +C + C(1) = 0.D0 + C(2) = 5.55555555555555555555555555556D-2 + C(3) = 8.33333333333333333333333333334D-2 + C(4) = 1.25D-1 + C(5) = 3.125D-1 + C(6) = 3.75D-1 + C(7) = 1.475D-1 + C(8) = 4.65D-1 + C(9) = 5.64865451382259575398358501426D-1 + C(10) = 6.5D-1 + C(11) = 9.24656277640504446745013574318D-1 + C(12) = 1.D0 + C(13) = C(12) +C + GO TO 120 +C +C The definitions of all pairs come here for the calculation of +C LSTSTG, RS1, RS2, RS3, RS4, COST, MAXTRY, EXPON, TOOSML, and VECSTG. +C + 120 CONTINUE + LSTSTG = PTR(NSTAGE) + IF (FSAL) THEN + COST = DBLE(NSTAGE-1) + ELSE + COST = DBLE(NSTAGE) + END IF +C +C MAXTRY - limit on the number of iterations of a computation made in +C diagnosing stiffness. There are at most Q = 3 function calls per +C iteration. MAXTRY is determined so that Q*MAXTRY <= 5% of the cost of +C 50 steps and 1 <= MAXTRY <= 8. This limits the number of calls to FCN +C in each diagnosis of stiffness to 24 calls. +C + MAXTRY = MIN(8,MAX(1,INT(FIVEPC*COST*FIFTY))) +C + EXPON = ONE/(ORDER+ONE) +C +C In calculating CDIFF it is assumed that there will be a non-zero +C difference |C(I) - C(J)| less than one. If C(I) = C(J) for any I not +C equal to J, they should be made precisely equal by assignment. +C + CDIFF = ONE + DO 160 I = 1, NSTAGE - 1 + DO 140 J = I + 1, NSTAGE + DIFF = ABS(C(I)-C(J)) + IF (DIFF.NE.ZERO) CDIFF = MIN(CDIFF,DIFF) + 140 CONTINUE + 160 CONTINUE + TOOSML = RNDOFF/CDIFF +C +C Determine the number of columns needed in STAGES(1:NEQ,*) (this will be +C at most NSTAGE-1 since the first stage is held in a separate array). +C The PTR array contains the column positions of the stages. +C + VECSTG = 0 + DO 180 I = 2, NSTAGE + VECSTG = MAX(PTR(I),VECSTG) + 180 CONTINUE +C + RS = TWO + RS1 = ONE/RS + RS2 = RS**2 + RS3 = RS**3 + RS4 = ONE/RS3 +C + RETURN + END + SUBROUTINE FORMI(F,NEQ,NWANT,Y,YP,YOLD,YPOLD,STAGES,CALSTG, + & XSTAGE,P) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: Forms an interpolating polynomial for use with +C METHDs 1 or 2. +C +C Input: NEQ, NWANT, T, Y(*), YP(*), HOLD, YOLD(*), YPOLD(*), +C STAGES(NEQ,*), CALSTG +C Output: P(*), XSTAGE(NEQ) +C External: F +C +C Common: Initializes: none +C Reads: /RKCOM4/ A(*,*), C(*), R(*), METHD, MINTP +C /RKCOM2/ T, TOLD, HOLD +C Alters: /RKCOM2/ NFCN +C +C Comments: +C ========= +C The integration has reached T with a step HOLD from TOLD = T-HOLD. +C Y(*),YP(*) and YOLD(*),YPOLD(*) approximate the solution and its +C derivative at T and TOLD respectively. STAGES(NEQ,*) holds the stages +C computed in taking this step. In the case of METHD = 2 it is necessary +C to compute some more stages in this subroutine. CALSTG indicates whether +C or not the extra stages need to be computed. A(*,*) and C(*) are used in +C computing these stages. The extra stages are stored in STAGES(NEQ,*) and +C XSTAGE(*). The coefficients of the interpolating polynomials for the first +C NWANT components of the solution are returned in the array P(*). The +C polynomial is of degree MINTP = 3 for METHD = 1 and of degree MINTP = 6 +C for METHD = 2. The vector R(*) is used for workspace when METHD = 2. +C +C .. Scalar Arguments .. + INTEGER NEQ, NWANT + LOGICAL CALSTG +C .. Array Arguments .. + DOUBLE PRECISION P(*), STAGES(NEQ,*), XSTAGE(*), Y(*), YOLD(*), + & YP(*), YPOLD(*) +C .. Subroutine Arguments .. + EXTERNAL F +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block to hold Formula Definitions .. + DOUBLE PRECISION A(13,13), B(13), C(13), BHAT(13), R(11,6), + & E(7) + INTEGER PTR(13), NSTAGE, METHD, MINTP + LOGICAL INTP + COMMON /RKCOM4/ A, B, C, BHAT, R, E, PTR, NSTAGE, METHD, + & MINTP, INTP + SAVE /RKCOM4/ +C .. Local Scalars .. + DOUBLE PRECISION D1, D2, D3, D4, HYP, HYPOLD + INTEGER I, J, K, L +C .. Executable Statements .. +C + IF (METHD.EQ.1) THEN +C +C METHD = 1. Use the cubic Hermite interpolant that is is fully +C specified by the values and slopes at the two ends of the step. +C + DO 20 L = 1, NWANT + D1 = Y(L) - YOLD(L) + HYP = HOLD*YP(L) + HYPOLD = HOLD*YPOLD(L) + D2 = HYP - D1 + D3 = D1 - HYPOLD + D4 = D2 - D3 + P(L) = D2 + D4 + P(NWANT+L) = D4 + 20 CONTINUE +C + ELSE +C +C METHD = 2. +C + IF (CALSTG) THEN +C +C Compute the extra stages needed for interpolation using the facts that +C 1. Stage 1 is YPOLD(*). +C 2. Stage i (i>1) is stored in STAGES(1:NEQ,i). +C 3. This pair is FSAL, i.e. STAGES(1:NEQ,7)=YP(1:NEQ), which frees +C up STAGES(1:NEQ,7) for use by stage 9. +C 4. XSTAGE(1:NEQ) is used for stage 10. +C 5. The coefficient of stage 2 in the interpolant is always 0, so +C STAGES(1:NEQ,1) is used for stage 11. +C The vector P(1:NEQ) is used as workspace for computing the stages. +C + DO 180 I = 9, 11 + DO 40 L = 1, NEQ + P(L) = A(I,1)*YPOLD(L) + 40 CONTINUE + DO 140 J = 2, I - 1 + IF (J.LE.7) THEN + DO 60 L = 1, NEQ + P(L) = P(L) + A(I,J)*STAGES(L,J-1) + 60 CONTINUE + ELSE IF (J.EQ.8) THEN + DO 80 L = 1, NEQ + P(L) = P(L) + A(I,J)*YP(L) + 80 CONTINUE + ELSE IF (J.EQ.9) THEN + DO 100 L = 1, NEQ + P(L) = P(L) + A(I,J)*STAGES(L,7) + 100 CONTINUE + ELSE IF (J.EQ.10) THEN + DO 120 L = 1, NEQ + P(L) = P(L) + A(I,J)*XSTAGE(L) + 120 CONTINUE + END IF + 140 CONTINUE + DO 160 L = 1, NEQ + P(L) = YOLD(L) + HOLD*P(L) + 160 CONTINUE + IF (I.EQ.9) THEN + CALL F(TOLD+C(I)*HOLD,P,STAGES(1,7)) + NFCN = NFCN + 1 + ELSE IF (I.EQ.10) THEN + CALL F(TOLD+C(I)*HOLD,P,XSTAGE) + NFCN = NFCN + 1 + ELSE + CALL F(TOLD+C(I)*HOLD,P,STAGES(1,1)) + NFCN = NFCN + 1 + END IF + 180 CONTINUE + END IF +C +C Form the coefficients of the interpolating polynomial in its shifted +C and scaled form. The transformation from the form in which the +C polynomial is derived can be somewhat ill-conditioned. The terms +C are grouped so as to minimize the errors of the transformation. +C +C Coefficient of SIGMA**6 + K = 4*NWANT + DO 200 L = 1, NWANT + P(K+L) = R(5,6)*STAGES(L,4) + + & ((R(10,6)*XSTAGE(L)+R(8,6)*YP(L))+ + & (R(7,6)*STAGES(L,6)+R(6,6)*STAGES(L,5))) + + & ((R(4,6)*STAGES(L,3)+R(9,6)*STAGES(L,7))+ + & (R(3,6)*STAGES(L,2)+R(11,6)*STAGES(L,1))+ + & R(1,6)*YPOLD(L)) + 200 CONTINUE +C +C Coefficient of SIGMA**5 + K = 3*NWANT + DO 220 L = 1, NWANT + P(K+L) = (R(10,5)*XSTAGE(L)+R(9,5)*STAGES(L,7)) + + & ((R(7,5)*STAGES(L,6)+R(6,5)*STAGES(L,5))+ + & R(5,5)*STAGES(L,4)) + ((R(4,5)*STAGES(L,3)+ + & R(8,5)*YP(L))+(R(3,5)*STAGES(L,2)+R(11,5)* + & STAGES(L,1))+R(1,5)*YPOLD(L)) + 220 CONTINUE +C +C Coefficient of SIGMA**4 + K = 2*NWANT + DO 240 L = 1, NWANT + P(K+L) = ((R(4,4)*STAGES(L,3)+R(8,4)*YP(L))+ + & (R(7,4)*STAGES(L,6)+R(6,4)*STAGES(L,5))+ + & R(5,4)*STAGES(L,4)) + ((R(10,4)*XSTAGE(L)+ + & R(9,4)*STAGES(L,7))+(R(3,4)*STAGES(L,2)+ + & R(11,4)*STAGES(L,1))+R(1,4)*YPOLD(L)) + 240 CONTINUE +C +C Coefficient of SIGMA**3 + K = NWANT + DO 260 L = 1, NWANT + P(K+L) = R(5,3)*STAGES(L,4) + R(6,3)*STAGES(L,5) + + & ((R(3,3)*STAGES(L,2)+R(9,3)*STAGES(L,7))+ + & (R(10,3)*XSTAGE(L)+R(8,3)*YP(L))+R(1,3)* + & YPOLD(L))+((R(4,3)*STAGES(L,3)+R(11,3)* + & STAGES(L,1))+R(7,3)*STAGES(L,6)) + 260 CONTINUE +C +C Coefficient of SIGMA**2 +C + DO 280 L = 1, NWANT + P(L) = R(5,2)*STAGES(L,4) + ((R(6,2)*STAGES(L,5)+ + & R(8,2)*YP(L))+R(1,2)*YPOLD(L)) + + & ((R(3,2)*STAGES(L,2)+R(9,2)*STAGES(L,7))+ + & R(10,2)*XSTAGE(L)) + ((R(4,2)*STAGES(L,3)+ + & R(11,2)*STAGES(L,1))+R(7,2)*STAGES(L,6)) + 280 CONTINUE +C +C Scale all the coefficients by the step size. +C + DO 300 L = 1, NWANT*(MINTP-1) + P(L) = HOLD*P(L) + 300 CONTINUE +C + END IF +C + RETURN + END + SUBROUTINE EVALI(Y,YP,P,TWANT,REQEST,NWANT,YWANT,YPWANT) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +************************************************* +C +C Purpose: Evaluation of an interpolating polynomial and/or its +C first derivative. +C +C Input: Y(*), YP(*), P(NWANT,*), TWANT, REQEST, NWANT +C Output: YWANT(*), YPWANT(*) +C +C Common: Initializes: none +C Reads: /RKCOM2/ HOLD, T +C /RKCOM4/ MINTP +C Alters: none +C +C Comments: +C ========= +C The interpolant is evaluated at TWANT to approximate the solution, +C YWANT, and/or its first derivative there, YPWANT. Only the first +C NWANT components of the answer are computed. There are three cases +C that are indicated by the first character of REQEST: +C REQEST(1:1) = `S' or `s'- compute approximate `S'olution only. +C = `D' or `d'- compute approximate first `D'erivative +C of the solution only. +C = `B' or `b'- compute `B'oth approximate solution and +C first derivative. +C The coefficents of the polynomial are contained in Y(*), YP(*) and +C P(NWANT,*). +C +C .. Scalar Arguments .. + DOUBLE PRECISION TWANT + INTEGER NWANT + CHARACTER*(*) REQEST +C .. Array Arguments .. + DOUBLE PRECISION P(NWANT,*), Y(*), YP(*), YPWANT(*), YWANT(*) +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block to hold Formula Definitions .. + DOUBLE PRECISION A(13,13), B(13), C(13), BHAT(13), R(11,6), + & E(7) + INTEGER PTR(13), NSTAGE, METHD, MINTP + LOGICAL INTP + COMMON /RKCOM4/ A, B, C, BHAT, R, E, PTR, NSTAGE, METHD, + & MINTP, INTP + SAVE /RKCOM4/ +C .. Local Scalars .. + DOUBLE PRECISION SIGMA + INTEGER K, L + CHARACTER REQST1 +C .. Executable Statements .. +C +C Evaluate the interpolating polynomial of degree MINTP in terms of the +C shifted and scaled independent variable SIGMA. +C + SIGMA = (TWANT-T)/HOLD +C + REQST1 = REQEST(1:1) + IF (REQST1.EQ.'S' .OR. REQST1.EQ.'s' .OR. + & REQST1.EQ.'B' .OR. REQST1.EQ.'b') THEN +C + DO 20 L = 1, NWANT + YWANT(L) = P(L,MINTP-1)*SIGMA + 20 CONTINUE + DO 60 K = MINTP - 2, 1, -1 + DO 40 L = 1, NWANT + YWANT(L) = (YWANT(L)+P(L,K))*SIGMA + 40 CONTINUE + 60 CONTINUE + DO 80 L = 1, NWANT + YWANT(L) = (YWANT(L)+HOLD*YP(L))*SIGMA + Y(L) + 80 CONTINUE + END IF +C +C Evaluate the derivative of the interpolating polynomial. +C + IF (REQST1.EQ.'D' .OR. REQST1.EQ.'d' .OR. + & REQST1.EQ.'B' .OR. REQST1.EQ.'b') THEN +C +C The derivative of the interpolating polynomial with respect to TWANT +C is the derivative with respect to S divided by HOLD. +C + DO 100 L = 1, NWANT + YPWANT(L) = MINTP*P(L,MINTP-1)*SIGMA + 100 CONTINUE + DO 140 K = MINTP - 1, 2, -1 + DO 120 L = 1, NWANT + YPWANT(L) = (YPWANT(L)+K*P(L,K-1))*SIGMA + 120 CONTINUE + 140 CONTINUE + DO 160 L = 1, NWANT + YPWANT(L) = (YPWANT(L)+HOLD*YP(L))/HOLD + 160 CONTINUE + END IF +C + RETURN + END + SUBROUTINE RKMSG(IER,SRNAME,NREC,FLAG) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: To process error messages and terminate the program +C in the event of a "catastrophic" failure. +C +C Input: IER, SRNAME, NREC +C Output: FLAG +C +C Common: Initializes: none +C Reads: /RKCOM7/ OUTCH +C /RKCOM8/ MSG, UTASK +C /RKCOM9/ REC +C Alters: none +C +C Comments: +C ========= +C The output variable FLAG is assigned the value of the input variable IER. +C +C IER = -2 reports a successful call of the subroutine SRNAME and +C indicates that special action is to be taken elsewhere +C in the suite. FLAG is set and a return is effected. +C +C IER = 1 reports a successful call of the subroutine SRNAME. FLAG +C is set and a return is effected. +C +C 1 < IER < 911 and MSG = .TRUE.: a message of NREC records contained in +C the array REC(*) is written to the standard output channel, +C OUTCH. FLAG is set and a return is effected. +C +C IER = 911 reports a "catastrophic" error was detected in SRNAME. A +C message is written to OUTCH regardless of the value of MSG and +C normally the execution of the program is terminated. The +C execution is not terminated if the error is the result of an +C indirect call to CT, RESET, or INTRP through UT (UTASK = .TRUE.). +C Termination can be prevented by using the subroutine SOFTFL. +C +C IER = 912 reports that a "catastrophic" error was detected earlier and +C termination was prevented, but the user has failed to take +C appropriate remedial action. Execution is terminated. +C +C .. Scalar Arguments .. + INTEGER FLAG, IER, NREC + CHARACTER*(*) SRNAME +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Common Block for Integrator Options .. + LOGICAL MSG, UTASK + COMMON /RKCOM8/ MSG, UTASK + SAVE /RKCOM8/ +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ +C .. Parameters .. + INTEGER PLUS1 + LOGICAL ASK, TELL + PARAMETER (PLUS1=1,ASK=.TRUE.,TELL=.FALSE.) +C .. Local Scalars .. + INTEGER I + LOGICAL BADERR, OK, ON, UTCALL +C .. External Subroutines .. + EXTERNAL CHKFL, RKSIT, SOFTFL +C .. Executable Statements .. +C +C Check where the call came from - if it is an indirect call from UT, +C the run is not STOPped. + UTCALL = (SRNAME.EQ.'RESET' .OR. SRNAME.EQ.'CT' .OR. + & SRNAME.EQ.'INTRP') .AND. UTASK +C +C Check if can continue with integrator. + OK = (SRNAME.EQ.'CT' .OR. SRNAME.EQ.'UT') .AND. + & (IER.EQ.2 .OR. IER.EQ.3 .OR. IER.EQ.4) +C +C Check if program termination has been overridden. + CALL SOFTFL(ASK,ON) +C + IF ((MSG.AND.IER.GT.PLUS1) .OR. IER.GE.911) THEN + WRITE (OUTCH,'(/A)') ' **' + WRITE (OUTCH,'(A)') (REC(I),I=1,NREC) + IF (IER.GE.911) THEN + WRITE (OUTCH,'(A/A,A,A/A/)') + &' **', + &' ** Catastrophic error detected in ', SRNAME, '.', + &' **' + IF ((.NOT.(UTCALL.OR.ON).AND.IER.EQ.911) .OR. + & IER.EQ.912) THEN + WRITE (OUTCH,'(A/A/A)') + &' **', + &' ** Execution of your program is being terminated.', + &' **' + STOP + END IF + ELSE IF (OK) THEN + WRITE (OUTCH,'(A/A,A,A,I2,A/A/A)') + &' **', + &' ** Warning from routine ', SRNAME, ' with flag set ',IER, '.', + &' ** You can continue integrating this problem.', + &' **' + ELSE + WRITE (OUTCH,'(A/A,A,A,I2,A/A/A)') + &' **', + &' ** Warning from routine ', SRNAME, ' with flag set ',IER, '.', + &' ** You cannot continue integrating this problem.', + &' **' + END IF + END IF + DO 20 I = NREC + 1, 10 + REC(I) = ' ' + 20 CONTINUE + FLAG = IER +C +C TELL RKSIT the status of the routine associated with SRNAME + CALL RKSIT(TELL,SRNAME,FLAG) +C +C Indicate that a catastrophic error has been detected + BADERR = FLAG .GE. 911 + CALL CHKFL(TELL,BADERR) +C + RETURN +C + END + SUBROUTINE RKSIT(ASK,SRNAME,STATE) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: To save or enquire about the status of each +C subprogram in the suite. +C +C Input: ASK, SRNAME +C Input/output: STATE +C +C +C Comments: +C ========= +C SRNAME indicates which routine is of interest in the call to RKSIT. +C +C If ASK=.FALSE., then the value of STATE (which as used is the error +C flag) for the routine SRNAME is saved internally. This value of STATE +C is usually positive. There are two exceptions: +C 1. SRNAME='SETUP' and STATE=-1 indicates a completely new problem, +C so all SAVEd states are cleared. +C 2. STATE=-2 is used by some routines in the suite to indicate +C circumstances which require special action. +C +C If ASK=.TRUE., then RKSIT first checks to see if there were any +C catastrophic errors, that is, a SAVEd state has value 911. This should +C happen only when the user has overridden program termination in the event +C of catastrophic failures from routines in the package but has failed to +C take appropriate action. If this is the case, then RKSIT returns a value +C of STATE = 911 which forces a termination of execution inside RKMSG. If +C no catastrophic errors are flagged, then STATE returns the saved state +C value for the routine specified by SRNAME. +C +C .. Scalar Arguments .. + INTEGER STATE + LOGICAL ASK + CHARACTER*(*) SRNAME +C .. Parameters .. + INTEGER STATES, MINUS1 + PARAMETER (STATES=7,MINUS1=-1) +C .. Local Scalars .. + INTEGER I, NAME +C .. Local Arrays .. + INTEGER SVSTA(STATES) +C .. Save statement .. + SAVE SVSTA +C .. Data statements .. + DATA SVSTA/STATES*MINUS1/ +C .. Executable Statements .. +C + IF (SRNAME.EQ.'SETUP') THEN + NAME = 1 + ELSE IF (SRNAME.EQ.'UT') THEN + NAME = 2 + ELSE IF (SRNAME.EQ.'STAT') THEN + NAME = 3 + ELSE IF (SRNAME.EQ.'GLBERR') THEN + NAME = 4 + ELSE IF (SRNAME.EQ.'CT') THEN + NAME = 5 + ELSE IF (SRNAME.EQ.'INTRP') THEN + NAME = 6 + ELSE IF (SRNAME.EQ.'RESET') THEN + NAME = 7 + ELSE + NAME = 0 + END IF +C +C (Re)initialize if SETUP is telling RKSIT to do so. + IF (.NOT.ASK .AND. NAME.EQ.1 .AND. STATE.EQ.MINUS1) THEN + DO 20 I = 1, STATES + SVSTA(I) = MINUS1 + 20 CONTINUE + GO TO 60 + END IF +C +C Check for 911 on exit from a previous call. + IF (ASK) THEN + DO 40 I = 1, STATES + IF (SVSTA(I).EQ.911) THEN + STATE = 911 + GO TO 60 + END IF + 40 CONTINUE + END IF +C + IF (ASK) THEN + STATE = SVSTA(NAME) + ELSE + SVSTA(NAME) = STATE + END IF +C + 60 CONTINUE +C + RETURN + END + SUBROUTINE TRUERR(F,NEQ,Y,TOL,WEIGHT,ZY,ZYP,ZERROR,ZYNEW,ZERRES, + & ZSTAGE,IER) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: Compute a running RMS measure of the true (global) error +C for a general Runge-Kutta pair. +C +C +C Input: NEQ, Y(*), TOL, WEIGHT(*), +C Input/output: ZY(*), ZYP(*), ZERROR(*) +C Workspace: ZYNEW(*), ZERRES(*), ZSTAGE(NEQ,*) +C Output: IER +C External: F +C +C Common: Initializes: none +C Reads: /RKCOM2/ T, HOLD +C /RKCOM5/ TOOSML, ORDER, NSEC +C /RKCOM7/ TINY +C Alters: /RKCOM6/ MAXERR, LOCMAX, GNFCN +C +C Comments: +C ========= +C A secondary integration is performed using a fraction of the step size +C of the primary integration. ZY(*) and ZYP(*) are the approximate solution +C and first derivative of this secondary integration. ZERRES(*) contains the +C error estimates for the secondary integration. ZYNEW(*) and ZSTAGE(*,*) are +C workspace for taking a step. The error assessment is computed using the +C difference of the primary and secondary solutions at the primary +C integration points as an estimate of the true error there. The weights +C used are those of the error test of the primary integration. This error +C assessment is maintained in the vector ZERROR(*). MAXERR and LOCMAX +C contain the maximum contribution to the assessment and its location, +C respectively. The number of calls to F is counted by GNFCN. +C +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER IER, NEQ +C .. Array Arguments .. + DOUBLE PRECISION WEIGHT(*), Y(*), ZERRES(*), ZERROR(*), + & ZSTAGE(NEQ,*), ZY(*), ZYNEW(*), ZYP(*) +C .. Subroutine Arguments .. + EXTERNAL F +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Global Error Assessment .. + DOUBLE PRECISION MAXERR, LOCMAX + INTEGER GNFCN, PRZSTG, PRZY, PRZYP, PRZERS, PRZERR, + & PRZYNU + LOGICAL ERASON, ERASFL + COMMON /RKCOM6/ MAXERR, LOCMAX, GNFCN, PRZSTG, PRZY, PRZYP, + & PRZERS, PRZERR, PRZYNU, ERASON, ERASFL + SAVE /RKCOM6/ +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Parameters .. + DOUBLE PRECISION PT1, TEN, DUMMY + PARAMETER (PT1=0.1D0,TEN=10.0D0,DUMMY=1.0D0) +C .. Local Scalars .. + DOUBLE PRECISION DIFF, ERRMAX, HMIN, HSEC, MXERLC, TSEC, ZLERR, + & ZTEST1, ZTEST2 + INTEGER ISTEP, L, LEVEL + LOGICAL LDUMMY, MAIN +C .. Local Arrays .. + DOUBLE PRECISION DUMARR(1) +C .. External Subroutines .. + EXTERNAL STEP +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX +C .. Executable Statements .. + TSEC = T - HOLD + HSEC = HOLD/DBLE(NSEC) + HMIN = MAX(TINY,TOOSML*MAX(ABS(TSEC),ABS(T))) + IF (ABS(HSEC).LT.HMIN) THEN + IER = 6 + GO TO 120 + END IF + ZTEST1 = TOL/DBLE(NSEC) + ZTEST2 = TOL/TEN + LEVEL = 0 +C +C The subroutine STEP is used to take a step. In its use in the primary +C integration provision is made for getting on scale in the first step. +C In this situation only the subroutine might reduce the step size. By +C setting MAIN = .FALSE., the subroutine will take a step of the size input. +C In this use of the subroutine, all items of the call list appearing after +C MAIN are dummy variables. +C +C Perform secondary integration. + MAIN = .FALSE. + LDUMMY = .FALSE. + DO 60 ISTEP = 1, NSEC +C +C Take a step. + CALL STEP(F,NEQ,TSEC,ZY,ZYP,ZSTAGE,ZTEST1,HSEC,WEIGHT,ZYNEW, + & ZERRES,ZLERR,MAIN,DUMMY,DUMARR,LDUMMY) +C +C The primary integration is using a step size of HUSED and the secondary +C integration is using the smaller step size HSEC = HUSED/NSEC. If steps +C of this size were taken from the same starting point and the asymptotic +C behavior were evident, the smaller step size would result in a local error +C that is considerably smaller, namely by a factor of 1/(NSEC**(ORDER+1)). +C If the two approximate solutions are close and TOLR is neither too large nor +C too small, this should be approximately true. The step size is chosen in +C the primary integration so that the local error ERR is no larger than TOLR. +C The local error, ZLERR, of the secondary integration is compared to TOLR in +C an attempt to diagnose a secondary integration that is not rather more +C accurate than the primary integration. +C + IF (ZLERR.GE.ZTEST1) THEN + LEVEL = 2 + ELSE IF (ZLERR.GT.ZTEST2) THEN + LEVEL = LEVEL + 1 + END IF + IF (LEVEL.GE.2) THEN + IER = 6 + GO TO 120 + END IF +C +C Advance TSEC and the dependent variables ZY(*) and ZYP(*). + TSEC = T - DBLE(NSEC-ISTEP)*HSEC + DO 20 L = 1, NEQ + ZY(L) = ZYNEW(L) + 20 CONTINUE +C + IF (FSAL) THEN +C +C When FSAL = .TRUE., the derivative ZYP(*) is the last stage of the step. + DO 40 L = 1, NEQ + ZYP(L) = ZSTAGE(L,LSTSTG) + 40 CONTINUE + ELSE +C +C Call F to evaluate ZYP(*). + CALL F(TSEC,ZY,ZYP) + GNFCN = GNFCN + 1 + END IF +C + 60 CONTINUE +C +C Update the maximum error seen, MAXERR, and its location, LOCMAX. +C Use local variables ERRMAX and MXERLC. +C + ERRMAX = MAXERR + MXERLC = LOCMAX + DO 80 L = 1, NEQ + DIFF = ABS(ZY(L)-Y(L))/WEIGHT(L) + IF (DIFF.GT.ERRMAX) THEN + ERRMAX = DIFF + MXERLC = T + END IF + 80 CONTINUE +C +C If the global error is greater than 0.1D0, the solutions have diverged so +C far that comparing them may not provide a reliable estimate of the global +C error. The test is made before ZERROR(*) and MAXERR, LCMXER are updated so +C that on a failure, they refer to the last reliable results. +C + IF (ERRMAX.GT.PT1) THEN + IER = 6 + GO TO 120 + ELSE + MAXERR = ERRMAX + LOCMAX = MXERLC + DO 100 L = 1, NEQ + DIFF = ABS(ZY(L)-Y(L))/WEIGHT(L) + ZERROR(L) = ZERROR(L) + DIFF**2 + 100 CONTINUE + IER = 1 + END IF +C +C Exit point for TRUERR + 120 CONTINUE +C + RETURN + END + SUBROUTINE STEP(F,NEQ,TNOW,Y,YP,STAGES,TOL,HTRY,WEIGHT,YNEW, + & ERREST,ERR,MAIN,HMIN,THRES,PHASE2) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: To compute a step of an explicit Runge-Kutta +C method and estimate the local error of the step. +C +C Input: NEQ, TNOW, Y(*), YP(*), TOL, MAIN, HMIN, THRES(*) +C Input/output: HTRY, PHASE2, LAST, WEIGHT(*) +C Output: STAGES(NEQ,*), YNEW(*), ERREST(*), ERR +C +C Common: Initializes: none +C Reads: /RKCOM1/ TND +C /RKCOM2/ LAST +C /RKCOM4/ A, B, C, BHAT, PTR, NSTAGE, METHD +C /RKCOM5/ FSAL +C Alters: /RKCOM2/ NFCN, LAST +C /RKCOM6/ GNFCN +C +C Comments: +C ========= +C From an approximate solution Y(*) at TNOW and first derivative there, +C YP(*) = F(TNOW,Y,YP), a step is taken to get an approximation YNEW(*) +C at TNOW + HTRY. The Runge-Kutta method and how it is used are defined +C by A, B, C, BHAT, PTR, NSTAGE, METHD and FSAL. Intermediate stages +C of the method are stored in the array STAGES(NEQ,*). The error in +C each solution component is estimated and returned in ERREST(*). A +C weighted maximum norm of the local error, ERR, is formed. For some +C methods an intermediate error estimate can be computed before completion +C of the step (see routine STEPB); if the estimate is greater than the +C specified tolerance TOL, the computation of the step is terminated. +C +C When global error estimation is desired, two integrations are done. +C The usual integration is referred to as the "primary", or "main", +C integration (MAIN=.TRUE.). For global error estimation another, +C "secondary" integration (MAIN=.FALSE.) is carried out with a smaller +C step size. The weight vector WEIGHT(*) used in computing ERR is +C determined by the main integration. Thus this argument is output when +C MAIN = .TRUE. and input when MAIN = .FALSE.. +C +C When taking the first step in an integration, the logical variable +C PHASE2 may be input as .TRUE. and if the first step is the whole of +C the range of integration, then LAST will be .TRUE.. When PHASE2=.TRUE., +C the first three stages are monitored to help assure that the step +C size H is small enough for the integration to be stable and for the +C estimate of the error of the step to be credible. Calls are made to +C the subroutine STEPA for this purpose. If necessary, H will be +C reduced in STEPA (and LAST altered accordingly) and the step retried +C in STEP until an acceptable value is found. +C +C In the primary integration the number of calls to F is counted by +C NFCN, and in the secondary integration, by GNFCN. +C +C .. Scalar Arguments .. + DOUBLE PRECISION ERR, HMIN, HTRY, TNOW, TOL + INTEGER NEQ + LOGICAL MAIN, PHASE2 +C .. Array Arguments .. + DOUBLE PRECISION ERREST(*), STAGES(NEQ,*), THRES(*), WEIGHT(*), + & Y(*), YNEW(*), YP(*) +C .. Subroutine Arguments .. + EXTERNAL F +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block to hold Formula Definitions .. + DOUBLE PRECISION A(13,13), B(13), C(13), BHAT(13), R(11,6), + & E(7) + INTEGER PTR(13), NSTAGE, METHD, MINTP + LOGICAL INTP + COMMON /RKCOM4/ A, B, C, BHAT, R, E, PTR, NSTAGE, METHD, + & MINTP, INTP + SAVE /RKCOM4/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Global Error Assessment .. + DOUBLE PRECISION MAXERR, LOCMAX + INTEGER GNFCN, PRZSTG, PRZY, PRZYP, PRZERS, PRZERR, + & PRZYNU + LOGICAL ERASON, ERASFL + COMMON /RKCOM6/ MAXERR, LOCMAX, GNFCN, PRZSTG, PRZY, PRZYP, + & PRZERS, PRZERR, PRZYNU, ERASON, ERASFL + SAVE /RKCOM6/ +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0) +C .. Local Scalars .. + DOUBLE PRECISION AVGY, TSTG + INTEGER I, J, L + LOGICAL CUTBAK +C .. External Subroutines .. + EXTERNAL STEPA, STEPB +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN +C .. Executable Statements .. +C +C Many of the following loops over L = 1, NEQ have constant array values +C inside. The code is written with clarity in mind. Any optimizing +C compiler will identify these occurrences and take appropriate action. +C A check for zero multipliers has been included so as to prevent +C needless computation resulting from the storing of zero coefficients +C in the arrays for the sake of clarity. The array ERREST(*) is used +C for working storage in this computation. +C + 20 CONTINUE + IF (MAIN) THEN + IF (PHASE2) THEN +C +C Initialize weights for measuring the local error. + DO 40 L = 1, NEQ + WEIGHT(L) = MAX(THRES(L),ABS(Y(L))) + 40 CONTINUE + END IF + END IF +C + DO 140 I = 2, NSTAGE + DO 100 J = 1, I - 1 + IF (J.EQ.1) THEN + DO 60 L = 1, NEQ + ERREST(L) = A(I,1)*YP(L) + 60 CONTINUE + ELSE + IF (A(I,J).NE.ZERO) THEN + DO 80 L = 1, NEQ + ERREST(L) = ERREST(L) + A(I,J)*STAGES(L,PTR(J)) + 80 CONTINUE + END IF + END IF + 100 CONTINUE + DO 120 L = 1, NEQ + YNEW(L) = Y(L) + HTRY*ERREST(L) + 120 CONTINUE +C +C METHD = 2 is special in that an estimate of the local error can be +C formed before the step is completed. If the step is a failure, +C return immediately. Otherwise, complete the step and compute a more +C accurate error estimate. + IF (METHD.EQ.2 .AND. I.EQ.7) THEN + CALL STEPB(NEQ,Y,YP,HTRY,YNEW,STAGES,THRES,ERR,MAIN,WEIGHT) + IF (ERR.GT.TOL) RETURN + END IF +C + TSTG = TNOW + C(I)*HTRY + IF (MAIN .AND. LAST .AND. C(I).EQ.ONE) TSTG = TND + CALL F(TSTG,YNEW,STAGES(1,PTR(I))) +C +C Increment the counter for the number of function evaluations +C depending on whether the primary or secondary integration is taking +C place. + IF (MAIN) THEN + NFCN = NFCN + 1 + ELSE + GNFCN = GNFCN + 1 + END IF +C +C---------------------------------------------------------------------- +C When PHASE2 is .TRUE. we are in the second phase of the automatic +C selection of the initial step size. The results of the first three +C stages are monitored in the subroutine STEPA for evidence that H is +C too large -- instability and/or an unreliable estimate of the error +C of the step is then possible. When the subroutine believes H to be +C too large, it returns CUTBAK = .TRUE. and a suitably reduced H for +C another try. +C + IF (MAIN) THEN + IF (PHASE2) THEN + IF (I.LE.3 .AND. ABS(HTRY).GT.HMIN) THEN + CALL STEPA(TNOW,Y,YP,TSTG,YNEW,STAGES(1,PTR(I)), + & HTRY,WEIGHT,CUTBAK) + IF (CUTBAK) THEN + LAST = .FALSE. +C +C Make sure that STEPA does not reduce the step size below the +C minimum. If it does, reset H to HMIN and deactivate PHASE2. + IF (ABS(HTRY).LE.HMIN) THEN + HTRY = SIGN(HMIN,HTRY) + PHASE2 = .FALSE. + END IF + GO TO 20 + END IF + END IF + END IF + END IF +C---------------------------------------------------------------------- +C + 140 CONTINUE +C +C Some formulas are constructed so that the last stage represents +C the result of the step (FSAL=.TRUE.), hence if the step is acceptable, +C it will be the first stage for the next step. When FSAL=.FALSE., we +C have to complete the computation of the step. +C + IF (.NOT.FSAL) THEN + DO 200 I = 1, NSTAGE + IF (I.EQ.1) THEN + DO 160 L = 1, NEQ + ERREST(L) = BHAT(1)*YP(L) + 160 CONTINUE + ELSE + IF (BHAT(I).NE.ZERO) THEN + DO 180 L = 1, NEQ + ERREST(L) = ERREST(L) + BHAT(I)*STAGES(L,PTR(I)) + 180 CONTINUE + END IF + END IF + 200 CONTINUE + DO 220 L = 1, NEQ + YNEW(L) = Y(L) + HTRY*ERREST(L) + 220 CONTINUE + END IF +C +C Form an estimate of the error in the lower order formula by comparing +C it to the higher order formula of the pair. ERREST(*) has been used +C as working storage above. The higher order approximation has been +C formed as YNEW(*) = Y(*) + HTRY*ERREST(*) where ERREST(*) is a linear +C combination of the stages of the formula. The lower order result also +C has the form Y(*) plus HTRY times a different linear combination of +C the stages. Hence, this different linear combination of stages for +C the lower order formula can just be subtracted from the combination +C stored in ERREST(*) to produce the errors. The result is then +C multiplied by HTRY to obtain the error estimate. +C + DO 280 I = 1, NSTAGE + IF (I.EQ.1 .AND. B(1).NE.ZERO) THEN + DO 240 L = 1, NEQ + ERREST(L) = ERREST(L) - B(1)*YP(L) + 240 CONTINUE + ELSE + IF (B(I).NE.ZERO) THEN + DO 260 L = 1, NEQ + ERREST(L) = ERREST(L) - B(I)*STAGES(L,PTR(I)) + 260 CONTINUE + END IF + END IF + 280 CONTINUE + DO 300 L = 1, NEQ + ERREST(L) = HTRY*ERREST(L) + 300 CONTINUE +C +C The error in a solution component is measured relative to a weight +C that is the larger of a threshold and the size of the solution over +C the step. Using the magnitude of a solution component at both ends +C of the step in the definition of "size" increases the robustness of +C the test. When global error estimation is specified, the weight +C vector WEIGHT(*) is defined by the primary integration and is then +C used in the secondary integration. +C + IF (MAIN) THEN + DO 320 L = 1, NEQ + AVGY = HALF*(ABS(Y(L))+ABS(YNEW(L))) + WEIGHT(L) = MAX(AVGY,THRES(L)) + 320 CONTINUE + END IF +C + ERR = ZERO + DO 340 L = 1, NEQ + ERR = MAX(ERR,ABS(ERREST(L)/WEIGHT(L))) + 340 CONTINUE +C + RETURN + END + SUBROUTINE STEPA(TNOW,Y,YP,TSTG,YSTG,YPSTG,HTRY,WEIGHT,CUTBAK) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: To calculate an "on-scale" step size for phase 2 of +C the initial step size computation. +C +C Input: TNOW, Y(*), YP(*), TSTG, YSTG(*), YPSTG(*) +C Input/output: HTRY, WEIGHT +C Output: CUTBAK +C +C Common: Initializes: none +C Reads: /RKCOM1/ TND, NEQ +C /RKCOM5/ STBRAD, RS1, RS4 +C /RKCOM7/ RNDOFF +C Alters: none +C +C Comments: +C ========= +C This subroutine is used during the first three stages of the first step. +C A Lipschitz constant L for the differential equation in autonomous form +C is approximated, and the product abs(HTRY)*L is compared to an approximate +C radius, STBRAD, of the stability region of the method. The step size is +C reduced as necessary, within a range specified by the step size control +C parameters RS1 and RS4, to assure stability and give some confidence in +C the error estimator. If HTRY is reduced, CUTBAK is set .TRUE.. +C +C Y(*) and YP(*) contain the solution and its derivative at TNOW and +C similarly YSTG(*) and YPSTG(*) contain approximations at TSTG. +C +C Normally the weights used in the control of the error depend on the +C size of the solution at the beginning and at the end of the step, but +C at this time we do not have a solution at the end of the step. Each +C stage YSTG(*) of the Runge - Kutta process represents a low order +C approximation to the solution at TSTG. Because the initial value of +C WEIGHT(*) provided in the first phase of the scheme is based only on +C the solution at T and THRES(*), it is continually updated in STEPA to +C account for the size of the solution throughout the step as revealed +C by the intermediate stages YSTG(*). Inside this subroutine only, the +C differential equation is converted to autonomous form. After the +C conversion, the end of the interval of integration, TND, is used +C to define a suitable weight for the independent variable. +C +C .. Scalar Arguments .. + DOUBLE PRECISION HTRY, TNOW, TSTG + LOGICAL CUTBAK +C .. Array Arguments .. + DOUBLE PRECISION WEIGHT(*), Y(*), YP(*), YPSTG(*), YSTG(*) +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D0) +C .. Local Scalars .. + DOUBLE PRECISION ARGDIF, FDIFF, SCL, TDIFF, TWT, WT, YNRM, YSTGNM + INTEGER L +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. Executable Statements .. +C +C Update the weights to account for the current intermediate solution +C approximation YSTG(*). Compute the sizes of Y(*) and YSTG(*) in the +C new norm. The size of the Lipschitz constant is assessed by a difference +C in the arguments Y(*), YSTG(*) and a difference in the function evaluated +C at these arguments. +C + YNRM = ZERO + YSTGNM = ZERO + ARGDIF = ZERO + FDIFF = ZERO + DO 20 L = 1, NEQN + WT = MAX(WEIGHT(L),ABS(YSTG(L))) + WEIGHT(L) = WT + YNRM = MAX(YNRM,ABS(Y(L))/WT) + YSTGNM = MAX(YSTGNM,ABS(YSTG(L))/WT) + ARGDIF = MAX(ARGDIF,ABS(YSTG(L)-Y(L))/WT) + FDIFF = MAX(FDIFF,ABS(YPSTG(L)-YP(L))/WT) + 20 CONTINUE +C +C The transformation of the equation to autonomous form is done +C implicitly. The difference of the arguments must take into account +C the difference between the values of the independent variable T and +C TSTG. The difference of the corresponding component of the function +C is zero because of the way the standard transformation is done. +C + TDIFF = TSTG - TNOW + TWT = ABS(TND-TNOW) + YNRM = MAX(YNRM,ABS(TNOW)/TWT) + YSTGNM = MAX(YSTGNM,ABS(TSTG)/TWT) + ARGDIF = MAX(ARGDIF,ABS(TDIFF)/TWT) +C +C The ratio FDIFF/ARGDIF is a lower bound for, and an approximation to, a +C Lipschitz constant L for the differential equation written in autonomous +C form. First we must ask if the difference ARGDIF is significant in the +C precision available. If it appears to be, we insist that abs(HTRY)*L be +C less than an approximate radius, STBRAD, of the stability region of the +C method. This is more stringent than necessary for stability, possibly a +C lot more stringent, but the aim is to get an HTRY small enough that the +C error estimate for the step is credible. The reduction is required to be +C at least as much as the step control parameter RS1. It is necessary to +C limit the reduction of HTRY at any one time because we may be misled in +C the size of the reduction that is appropriate due to nonlinearity of the +C differential equation and to inaccurate weights caused by HTRY much too +C large. The reduction is not permitted to be more than the step control +C parameter RS4. +C + CUTBAK = .FALSE. + IF (ARGDIF.GT.RNDOFF*MAX(YNRM,YSTGNM)) THEN + IF ((ABS(HTRY)*FDIFF).GT.(STBRAD*ARGDIF)) THEN + SCL = (STBRAD*ARGDIF)/(ABS(HTRY)*FDIFF) + SCL = MIN(SCL,RS1) + SCL = MAX(SCL,RS4) + HTRY = SCL*HTRY + CUTBAK = .TRUE. + END IF + END IF +C + RETURN + END + SUBROUTINE STEPB(NEQ,Y,YP,H,YNEW,STAGES,THRES,ERR,MAIN,WEIGHT) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: To compute an error estimate for METHD = 2 prior +C to completing the step. +C +C Input: NEQ, Y(*), YP(*), H, STAGES(NEQ,*), THRES(*), MAIN, +C WEIGHT(*) +C Output: ERR +C +C Common: Initializes: none +C Reads: /RKCOM4/ E, PTR +C Alters: none +C +C Comments: +C ========= +C If global error assessment is taking place, then MAIN = .FALSE. and +C the weight vector generated by the primary integration is used. The +C error estimate is a linear combination (with coefficients in E(*)) +C of the stages stored in STAGES(*,*) (located by PTR(*)). +C +C .. Scalar Arguments .. + DOUBLE PRECISION ERR, H + INTEGER NEQ + LOGICAL MAIN +C .. Array Arguments .. + DOUBLE PRECISION STAGES(NEQ,*), THRES(*), WEIGHT(*), Y(*), + & YNEW(*), YP(*) +C .. Common Block to hold Formula Definitions .. + DOUBLE PRECISION A(13,13), B(13), C(13), BHAT(13), R(11,6), + & E(7) + INTEGER PTR(13), NSTAGE, METHD, MINTP + LOGICAL INTP + COMMON /RKCOM4/ A, B, C, BHAT, R, E, PTR, NSTAGE, METHD, + & MINTP, INTP + SAVE /RKCOM4/ +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF + PARAMETER (ZERO=0.0D0,HALF=0.5D0) +C .. Local Scalars .. + DOUBLE PRECISION AVGY, SUM, WT + INTEGER INDEX, L +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. Executable Statements .. +C + ERR = ZERO + DO 40 L = 1, NEQ +C +C Estimate the local error of component L. The coding makes use of +C E(2) = 0.0D0 and E(7) = 0.0D0. +C + SUM = E(1)*YP(L) + DO 20 INDEX = 3, 6 + SUM = SUM + E(INDEX)*STAGES(L,PTR(INDEX)) + 20 CONTINUE +C +C The local error is H*SUM. A weighted maximum norm of SUM is formed +C and then the factor of H is taken into account. +C + IF (MAIN) THEN + AVGY = HALF*(ABS(Y(L))+ABS(YNEW(L))) + WT = MAX(AVGY,THRES(L)) + ELSE + WT = WEIGHT(L) + END IF +C + ERR = MAX(ERR,ABS(SUM/WT)) + 40 CONTINUE + ERR = ABS(H)*ERR +C + RETURN + END + SUBROUTINE STIFF(F,HAVG,JFLSTP,TOOMCH,MAXFCN,WORK,IER,NREC) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: Diagnose stiffness. This depends on two things: whether +C the step size is being restricted on grounds of stability +C and whether the integration to TND can be completed in no +C more than MAXFCN function evaluations. +C +C Input: HAVG, TOOMCH, MAXFCN, WORK(*) +C Input/output: JFLSTP +C Output: IER, NREC +C Workspace: WORK(*) +C External: F +C +C Common: Initializes: /RKCOM9/ REC +C Reads: /RKCOM1/ TND, NEQN +C /RKCOM2/ T, H, NFCN, SVNFCN, OKSTP +C /RKCOM3/ PRY, PRYP, PRTHRS, PRWT, PRSCR, +C PRSTGS, PRYOLD +C /RKCOM5/ COST +C Alters: /RKCOM2/ NFCN +C /RKCOM9/ REC +C +C .. Scalar Arguments .. + DOUBLE PRECISION HAVG + INTEGER IER, JFLSTP, MAXFCN, NREC + LOGICAL TOOMCH +C .. Array Arguments .. + DOUBLE PRECISION WORK(*) +C .. Subroutine Arguments .. + EXTERNAL F +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Common Block for General Workspace Pointers .. + INTEGER PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + COMMON /RKCOM3/ PRTHRS, PRERST, PRWT, PRYOLD, PRSCR, PRY, PRYP, + & PRSTGS, PRINTP, LNINTP + SAVE /RKCOM3/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Error Message .. + CHARACTER*80 REC(10) + COMMON /RKCOM9/ REC + SAVE /RKCOM9/ +C .. Parameters .. + DOUBLE PRECISION HALF + PARAMETER (HALF=0.5D0) +C .. Local Scalars .. + DOUBLE PRECISION AVGY, XTRAWK + INTEGER L + LOGICAL LOTSFL, STIF, UNSURE +C .. External Subroutines .. + EXTERNAL STIFFA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MOD +C .. Executable Statements .. +C + IF (MOD(OKSTP-10,40).EQ.0) THEN + LOTSFL = JFLSTP .GE. 10 + JFLSTP = 0 + ELSE + LOTSFL = .FALSE. + END IF +C +C If either too much work has been done or there are lots of failed steps, +C test for stiffness. +C + IF (TOOMCH .OR. LOTSFL) THEN +C +C Regenerate weight vector + DO 20 L = 1, NEQN + AVGY = HALF*(ABS(WORK(PRY-1+L))+ABS(WORK(PRYOLD-1+L))) + WORK(PRWT-1+L) = MAX(AVGY,WORK(PRTHRS-1+L)) + 20 CONTINUE +C +C STIFFA determines whether the problem is STIFF. In some circumstances it +C is UNSURE. The decision depends on two things: whether the step size is +C being restricted on grounds of stability and whether the integration to +C TND can be completed in no more than MAXFCN function evaluations. The +C last four arguments of STIFFA are vectors of length NEQN used for working +C storage. Some storage in WORK(*) reserved for the stages (there are a +C minimum of three such vectors reserved for the METHDs implemented) and +C the scratch vector starting at PRSCR are used for this purpose. +C + CALL STIFFA(F,T,WORK(PRY),H,HAVG,TND,MAXFCN,WORK(PRWT), + & WORK(PRYP),WORK(PRERST),UNSURE,STIF,WORK(PRSTGS), + & WORK(PRSTGS+NEQN),WORK(PRSTGS+2*NEQN),WORK(PRSCR)) + IF (.NOT.UNSURE) THEN + IF (STIF) THEN +C +C Predict how much eXTRA WorK will be needed to reach TND. + XTRAWK = (COST*ABS((TND-T)/HAVG))/DBLE(SVNFCN+NFCN) + IER = 4 + WRITE (REC(NREC+1),'(A)') + &' ** Your problem has been diagnosed as stiff. If the ' + WRITE (REC(NREC+2),'(A,D13.5)') + &' ** situation persists, it will cost roughly ', XTRAWK + WRITE (REC(NREC+3),'(A)') + &' ** times as much to reach TEND as it has cost to reach TNOW.' + WRITE (REC(NREC+4),'(A)') + &' ** You should probably change to a code intended for ' + WRITE (REC(NREC+5),'(A)') + &' ** stiff problems. ' + NREC = NREC + 5 + END IF + END IF + END IF +C + RETURN + END + SUBROUTINE STIFFA(F,X,Y,HNOW,HAVG,XEND,MAXFCN,WT,FXY,V0,UNSURE, + & STIF,V1,V2,V3,VTEMP) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C External: F +C Input: X, Y(*), HNOW, HAVG, XEND, MAXFCN, WT(*), FXY(*) +C Input/Output V0(*) +C Output: UNSURE, STIF +C Workspace: V1(*), V2(*), V3(*), VTEMP(*) +C +C Common: Initializes: none +C Reads: /RKCOM1/ TND, NEQN +C /RKCOM5/ COST, STBRAD, TANANG +C /RKCOM7/ SQRRMC, CUBRMC +C Alters: none +C +C STIFFA diagnoses stiffness for an explicit Runge-Kutta code. When it +C is called, either many step failures have been observed, or a lot of +C work has been done. +C +C The NEQ equations of the problem are defined by the subroutine F(X,Y,YP). +C When STIFFA is called, the integration has reached X where the approximate +C solution is Y(*). The vector FXY(*) is defined by a call of F(X,Y,FXY). +C It is an input argument because it is usually available from the integrator. +C +C The last successful step was of size HNOW, and an average step size is +C HAVG. A weighted norm is used to measure the local error with the error +C in solution component L divided by the positive weight WT(L) provided in +C the vector WT(*). +C +C Explicit Runge - Kutta codes estimate the local error of Y(*) by +C forming the difference of two approximate solutions. This difference +C must be provided in the vector V0(*). When this difference is too +C small to be significant, STIFFA will replace it with a "random" vector. +C +C STIF is set .TRUE. when the average step size appears to be restricted +C on grounds of stability. In certain cases the variable UNSURE is set +C .TRUE.; the value of STIF is then not defined. +C +C The stability region of the explicit Runge-Kutta formula is described +C by quantities TANANG and STBRAD that are communicated by the setup routine +C via COMMON. Stability regions often change sharply near the imaginary +C axis so that it is difficult to classify the stiffness of a problem with +C eigenvalues of a local Jacobian that are "near" the imaginary axis. For +C this reason, we consider only points Z in the upper left half complex +C plane for which TAN( IMAG(Z)/( - RE(Z))) <= TANANG. Eigenvalues outside +C this region are one reason for the code being UNSURE. The stability +C region is approximated by the intersection of a disk with this sector. +C The radius of this disk is called STBRAD. +C +C Working storage must be provided via the four vectors V1(*),V2(*), +C V3(*),VTEMP(*). These vectors must be of length at least NEQ. +C +C .. Scalar Arguments .. + DOUBLE PRECISION HAVG, HNOW, X, XEND + INTEGER MAXFCN + LOGICAL STIF, UNSURE +C .. Array Arguments .. + DOUBLE PRECISION FXY(*), V0(*), V1(*), V2(*), V3(*), VTEMP(*), + & WT(*), Y(*) +C .. Subroutine Arguments .. + EXTERNAL F +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Formula Characterisitcs .. + DOUBLE PRECISION TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4 + INTEGER ORDER, LSTSTG, MAXTRY, NSEC + LOGICAL FSAL + COMMON /RKCOM5/ TOOSML, COST, SAFETY, EXPON, STBRAD, TANANG, + & RS, RS1, RS2, RS3, RS4, ORDER, LSTSTG, MAXTRY, + & NSEC, FSAL + SAVE /RKCOM5/ +C .. Common Block for Environment Parameters .. + DOUBLE PRECISION MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY + INTEGER OUTCH + COMMON /RKCOM7/ MCHEPS, DWARF, RNDOFF, SQRRMC, CUBRMC, TINY, + & OUTCH + SAVE /RKCOM7/ +C .. Parameters .. + DOUBLE PRECISION LARGE + PARAMETER (LARGE=1.0D+10) + DOUBLE PRECISION ZERO, P001, P9, ONE, TWO, FIVE, FIFTH + PARAMETER (ZERO=0.0D+0,P001=0.001D+0,P9=0.9D+0,ONE=1.0D+0, + & TWO=2.0D+0,FIVE=5.0D+0,FIFTH=0.2D+0) +C .. Local Scalars .. + DOUBLE PRECISION ALPHA1, ALPHA2, BETA1, BETA2, D1, D2, DET1, + & DET2, DIST, RES2, RHO, RHO2, ROLD, SCALE, V0NRM, + & V0V0, V0V1, V0V2, V1V1, V1V2, V1V3, V2V2, V2V3, + & V3NRM, V3V3, XTRFCN, YNRM + INTEGER L, NTRY + LOGICAL ROOTRE +C .. Local Arrays .. + DOUBLE PRECISION R1(2), R2(2), ROOT1(2), ROOT2(2) +C .. External Functions .. + DOUBLE PRECISION DOTPRD + EXTERNAL DOTPRD +C .. External Subroutines .. + EXTERNAL STIFFB, STIFFC, STIFFD +C .. Intrinsic Functions .. + INTRINSIC ABS, MIN, SQRT +C .. Executable Statements .. +C +C If the current step size differs substantially from the average, +C the problem is not stiff. +C + IF (ABS(HNOW/HAVG).GT.FIVE .OR. ABS(HNOW/HAVG).LT.FIFTH) THEN + STIF = .FALSE. + UNSURE = .FALSE. + RETURN + ELSE + UNSURE = .TRUE. + END IF +C +C The average step size is used to predict the cost in function evaluations +C of finishing the integration to XEND. If this cost is no more than MAXFCN, +C the problem is declared not stiff: If the step size is being restricted on +C grounds of stability, it will stay close to HAVG. The prediction will +C then be good, but the cost is too low to consider the problem stiff. If +C the step size is not close to HAVG, the problem is not stiff. Either way +C there is no point to testing for a step size restriction due to stability. +C + XTRFCN = COST*ABS((XEND-X)/HAVG) + IF (XTRFCN.LE.MAXFCN) THEN + STIF = .FALSE. + UNSURE = .FALSE. + RETURN + ELSE + UNSURE = .TRUE. + END IF +C +C There have been many step failures or a lot of work has been done. Now +C we must determine if this is due to the stability characteristics of the +C formula. This is done by calculating the dominant eigenvalues of the +C local Jacobian and then testing whether HAVG corresponds to being on the +C boundary of the stability region. +C +C The size of Y(*) provides scale information needed to approximate +C the Jacobian by differences. +C + YNRM = SQRT(DOTPRD(Y,Y,WT,NEQN)) + SCALE = YNRM*SQRRMC + IF (SCALE.EQ.ZERO) THEN +C +C Degenerate case. Y(*) is (almost) the zero vector so the scale is not +C defined. The input vector V0(*) is the difference between Y(*) and a +C lower order approximation to the solution that is within the error +C tolerance. When Y(*) vanishes, V0(*) is itself an acceptable approximate +C solution, so we take SCALE from it, if this is possible. +C + YNRM = SQRT(DOTPRD(V0,V0,WT,NEQN)) + SCALE = YNRM*SQRRMC + IF (SCALE.EQ.ZERO) THEN + UNSURE = .TRUE. + RETURN + END IF + END IF +C + V0V0 = DOTPRD(V0,V0,WT,NEQN) + IF (V0V0.EQ.ZERO) THEN +C +C Degenerate case. V0(*) is (almost) the zero vector so cannot +C be used to define a direction for an increment to Y(*). Try a +C "random" direction. +C + DO 20 L = 1, NEQN + V0(L) = ONE + 20 CONTINUE + V0V0 = DOTPRD(V0,V0,WT,NEQN) + END IF + V0NRM = SQRT(V0V0) + DO 40 L = 1, NEQN + V0(L) = V0(L)/V0NRM + 40 CONTINUE + V0V0 = ONE +C +C Use a nonlinear power method to estimate the two dominant eigenvalues. +C V0(*) is often very rich in the two associated eigenvectors. For this +C reason the computation is organized with the expectation that a minimal +C number of iterations will suffice. Indeed, it is necessary to recognize +C a kind of degeneracy when there is a dominant real eigenvalue. The +C subroutine STIFFB does this. In the first try, NTRY = 1, a Rayleigh +C quotient for such an eigenvalue is initialized as ROLD. After each +C iteration, REROOT computes a new Rayleigh quotient and tests whether the +C two approximations agree to one tenth of one per cent and the eigenvalue, +C eigenvector pair satisfy a stringent test on the residual. ROOTRE = .TRUE. +C signals that a single dominant real root has been found. +C + NTRY = 1 + 60 CONTINUE +C + CALL STIFFD(V0,HAVG,X,Y,F,FXY,WT,SCALE,V0V0,V1,V1V1,VTEMP) +C +C The quantity SQRT(V1V1/V0V0) is a lower bound for the product of HAVG +C and a Lipschitz constant. If it should be LARGE, stiffness is not +C restricting the step size to the stability region. The principle is +C clear enough, but the real reason for this test is to recognize an +C extremely inaccurate computation of V1V1 due to finite precision +C arithmetic in certain degenerate circumstances. +C + IF (SQRT(V1V1).GT.LARGE*SQRT(V0V0)) THEN + UNSURE = .TRUE. + RETURN + END IF +C + V0V1 = DOTPRD(V0,V1,WT,NEQN) + IF (NTRY.EQ.1) THEN + ROLD = V0V1/V0V0 +C +C This is the first Rayleigh quotient approximating the product of HAVG +C and a dominant real eigenvalue. If it should be very small, the +C problem is not stiff. It is important to test for this possibility so +C as to prevent underflow and degeneracies in the subsequent iteration. +C + IF (ABS(ROLD).LT.CUBRMC) THEN + UNSURE = .FALSE. + STIF = .FALSE. + RETURN + END IF + ELSE + CALL STIFFB(V1V1,V0V1,V0V0,ROLD,RHO,ROOT1,ROOT2,ROOTRE) + IF (ROOTRE) GO TO 100 + END IF + CALL STIFFD(V1,HAVG,X,Y,F,FXY,WT,SCALE,V1V1,V2,V2V2,VTEMP) + V0V2 = DOTPRD(V0,V2,WT,NEQN) + V1V2 = DOTPRD(V1,V2,WT,NEQN) + CALL STIFFB(V2V2,V1V2,V1V1,ROLD,RHO,ROOT1,ROOT2,ROOTRE) + IF (ROOTRE) GO TO 100 +C +C Fit a quadratic in the eigenvalue to the three successive iterates +C V0(*),V1(*),V2(*) of the power method to get a first approximation to +C a pair of eigenvalues. A test made earlier in STIFFB implies that +C the quantity DET1 here will not be too small. +C + DET1 = V0V0*V1V1 - V0V1**2 + ALPHA1 = (-V0V0*V1V2+V0V1*V0V2)/DET1 + BETA1 = (V0V1*V1V2-V1V1*V0V2)/DET1 +C +C Iterate again to get V3, test again for degeneracy, and then fit a +C quadratic to V1(*),V2(*),V3(*) to get a second approximation to a pair +C of eigenvalues. +C + CALL STIFFD(V2,HAVG,X,Y,F,FXY,WT,SCALE,V2V2,V3,V3V3,VTEMP) + V1V3 = DOTPRD(V1,V3,WT,NEQN) + V2V3 = DOTPRD(V2,V3,WT,NEQN) + CALL STIFFB(V3V3,V2V3,V2V2,ROLD,RHO,ROOT1,ROOT2,ROOTRE) + IF (ROOTRE) GO TO 100 + DET2 = V1V1*V2V2 - V1V2**2 + ALPHA2 = (-V1V1*V2V3+V1V2*V1V3)/DET2 + BETA2 = (V1V2*V2V3-V2V2*V1V3)/DET2 +C +C First test the residual of the quadratic fit to see if we might +C have determined a pair of eigenvalues. +C + RES2 = ABS(V3V3+V2V2*ALPHA2**2+V1V1*BETA2**2+TWO*V2V3*ALPHA2+ + & TWO*V1V3*BETA2+TWO*V1V2*ALPHA2*BETA2) + IF (RES2.LE.V3V3*P001**2) THEN +C +C Calculate the two approximate pairs of eigenvalues. +C + CALL STIFFC(ALPHA1,BETA1,R1,R2) + CALL STIFFC(ALPHA2,BETA2,ROOT1,ROOT2) +C +C The test for convergence is done on the larger root of the second +C approximation. It is complicated by the fact that one pair of roots +C might be real and the other complex. First calculate the spectral +C radius RHO of HAVG*J as the magnitude of ROOT1. Then see if one of +C the roots R1,R2 is within one per cent of ROOT1. A subdominant root +C may be very poorly approximated if its magnitude is much smaller than +C RHO -- this does not matter in our use of these eigenvalues. +C + RHO = SQRT(ROOT1(1)**2+ROOT1(2)**2) + D1 = (ROOT1(1)-R1(1))**2 + (ROOT1(2)-R1(2))**2 + D2 = (ROOT1(1)-R2(1))**2 + (ROOT1(2)-R2(2))**2 + DIST = SQRT(MIN(D1,D2)) + IF (DIST.LE.P001*RHO) GO TO 100 + END IF +C +C Do not have convergence yet. Because the iterations are cheap, and +C because the convergence criterion is stringent, we are willing to try +C a few iterations. +C + IF (NTRY.LT.MAXTRY) THEN + NTRY = NTRY + 1 + V3NRM = SQRT(V3V3) + DO 80 L = 1, NEQN + V0(L) = V3(L)/V3NRM + 80 CONTINUE + V0V0 = ONE + GO TO 60 + ELSE + UNSURE = .TRUE. + RETURN + END IF +C +C ************** +C +C We now have the dominant eigenvalues. Decide if the average step +C size is being restricted on grounds of stability. Check the real +C parts of the eigenvalues. First see if the dominant eigenvalue is +C in the left half plane -- there won't be a stability restriction +C unless it is. If there is another eigenvalue of comparable magnitude +C with a positive real part, the problem is not stiff. If the dominant +C eigenvalue is too close to the imaginary axis, we cannot diagnose +C stiffness. +C + 100 CONTINUE + IF (ROOT1(1).GT.ZERO) THEN + STIF = .FALSE. + UNSURE = .FALSE. + RETURN + END IF + RHO2 = SQRT(ROOT2(1)**2+ROOT2(2)**2) + IF (RHO2.GE.P9*RHO .AND. ROOT2(1).GT.ZERO) THEN + STIF = .FALSE. + UNSURE = .FALSE. + RETURN + END IF + IF (ABS(ROOT1(2)).GT.ABS(ROOT1(1))*TANANG) THEN + UNSURE = .TRUE. + RETURN + END IF +C +C If the average step size corresponds to being well within the +C stability region, the step size is not being restricted because +C of stability. +C + STIF = RHO .GE. P9*STBRAD + UNSURE = .FALSE. + RETURN + END + SUBROUTINE STIFFB(V1V1,V0V1,V0V0,ROLD,RHO,ROOT1,ROOT2,ROOTRE) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Input: V1V1, V0V1, V0V0 +C Input/output: ROLD +C Output: RHO, ROOT1(*),ROOT2(*),ROOTRE +C +C Decide if the iteration has degenerated because of a strongly +C dominant real eigenvalue. Have just computed the latest iterate. +C V1V1 is its dot product with itself, V0V1 is the dot product +C of the previous iterate with the current one, and V0V0 is the +C dot product of the previous iterate with itself. ROLD is a +C previous Rayleigh quotient approximating a dominant real +C eigenvalue. It must be computed directly the first time the +C subroutine is called. It is updated each call to STIFFB, hence +C is available for subsequent calls. +C +C If there is a strongly dominant real eigenvalue, ROOTRE is set +C .TRUE., ROOT1(*) returns the eigenvalue, RHO returns the magnitude +C of the eigenvalue, and ROOT2(*) is set to zero. +C +C .. Scalar Arguments .. + DOUBLE PRECISION RHO, ROLD, V0V0, V0V1, V1V1 + LOGICAL ROOTRE +C .. Array Arguments .. + DOUBLE PRECISION ROOT1(2), ROOT2(2) +C .. Parameters .. + DOUBLE PRECISION ZERO, P001 + PARAMETER (ZERO=0.0D+0,P001=0.001D+0) +C .. Local Scalars .. + DOUBLE PRECISION DET, R, RES +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + R = V0V1/V0V0 + RHO = ABS(R) + DET = V0V0*V1V1 - V0V1**2 + RES = ABS(DET/V0V0) + ROOTRE = DET .EQ. ZERO .OR. (RES.LE.V1V1*P001**2 .AND. + & ABS(R-ROLD).LE.P001*RHO) + IF (ROOTRE) THEN + ROOT1(1) = R + ROOT1(2) = ZERO + ROOT2(1) = ZERO + ROOT2(2) = ZERO + END IF + ROLD = R +C + RETURN + END + SUBROUTINE STIFFC(ALPHA,BETA,R1,R2) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Input: ALPHA, BETA +C Output: R1(*), R2(*) +C +C This subroutine computes the two complex roots R1 and R2 of +C the quadratic equation X**2 + ALPHA*X + BETA = 0. The magnitude +C of R1 is greater than or equal to the magnitude of R2. R1 and R2 are +C returned as vectors of two components with the first being the real +C part of the complex number and the second being the imaginary part. +C +C .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION R1(2), R2(2) +C .. Parameters .. + DOUBLE PRECISION ZERO, TWO + PARAMETER (ZERO=0.0D+0,TWO=2.0D+0) +C .. Local Scalars .. + DOUBLE PRECISION DISC, SQDISC, TEMP +C .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +C .. Executable Statements .. + TEMP = ALPHA/TWO + DISC = TEMP**2 - BETA + IF (DISC.EQ.ZERO) THEN +C +C Double root. +C + R1(1) = -TEMP + R1(2) = ZERO + R2(1) = R1(1) + R2(2) = R1(2) + RETURN + END IF +C + SQDISC = SQRT(ABS(DISC)) + IF (DISC.LT.ZERO) THEN +C +C Complex conjugate roots. +C + R1(1) = -TEMP + R1(2) = SQDISC + R2(1) = R1(1) + R2(2) = -R1(2) + ELSE +C +C Real pair of roots. Calculate the bigger one in R1(1). +C + IF (TEMP.GT.ZERO) THEN + R1(1) = -TEMP - SQDISC + ELSE + R1(1) = -TEMP + SQDISC + END IF + R1(2) = ZERO + R2(1) = BETA/R1(1) + R2(2) = ZERO + END IF +C + RETURN + END + SUBROUTINE STIFFD(V,HAVG,X,Y,F,FXY,WT,SCALE,VDOTV,Z,ZDOTZ,VTEMP) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C External: F +C Input: V(*), HAVG, X, Y(*), FXY(*), WT(*), SCALE, VDOTV, +C Output: Z(*), ZDOTZ +C Workspace: VTEMP(*) +C +C For an input vector V(*) of length NEQ, this subroutine computes a vector +C Z(*) that approximates the product HAVG*J*V where HAVG is an input scalar +C and J is the Jacobian matrix of a function F evaluated at the input +C arguments (X,Y(*)). This function is defined by a subroutine of the form +C F(T,U,F) that when given T and U(*), returns the value of the function in +C F(*). The input vector FXY(*) is defined by F(X,Y,FXY). Scaling is a +C delicate matter. A weighted Euclidean norm is used with the (positive) +C weights provided in WT(*). The input scalar SCALE is the square root of +C the unit roundoff times the norm of Y(*). The square of the norm of the +C input vector V(*) is input as VDOTV. The routine outputs the square of +C the norm of the output vector Z(*) as ZDOTZ. The subroutine calls the +C DOUBLE PRECISION FUNCTION DOTPRD(U,V,WT,NEQ) to compute the dot (inner) +C product. The vector VTEMP(*) is used for working storage. +C +C .. Scalar Arguments .. + DOUBLE PRECISION HAVG, SCALE, VDOTV, X, ZDOTZ +C .. Array Arguments .. + DOUBLE PRECISION FXY(*), V(*), VTEMP(*), WT(*), Y(*), Z(*) +C .. Subroutine Arguments .. + EXTERNAL F +C .. Common Block for Problem Definition .. + DOUBLE PRECISION TSTRT, TND, DIR, HSTRT, TOLR + INTEGER NEQN + COMMON /RKCOM1/ TSTRT, TND, DIR, HSTRT, TOLR, NEQN + SAVE /RKCOM1/ +C .. Common Block to hold Problem Status .. + DOUBLE PRECISION T, H, TOLD, HOLD + INTEGER NFCN, SVNFCN, OKSTP, FLSTP + LOGICAL FIRST, LAST + COMMON /RKCOM2/ T, H, TOLD, HOLD, NFCN, SVNFCN, OKSTP, FLSTP, + & FIRST, LAST + SAVE /RKCOM2/ +C .. Local Scalars .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER L +C .. External Functions .. + DOUBLE PRECISION DOTPRD + EXTERNAL DOTPRD +C .. Intrinsic Functions .. + INTRINSIC SQRT +C .. Executable Statements .. +C +C Scale V(*) so that it can be used as an increment to Y(*) +C for an accurate difference approximation to the Jacobian. +C + TEMP1 = SCALE/SQRT(VDOTV) + DO 20 L = 1, NEQN + VTEMP(L) = Y(L) + TEMP1*V(L) + 20 CONTINUE +C + CALL F(X,VTEMP,Z) + NFCN = NFCN + 1 +C +C Form the difference approximation. At the same time undo +C the scaling of V(*) and introduce the factor of HAVG. +C + TEMP2 = HAVG/TEMP1 + DO 40 L = 1, NEQN + Z(L) = TEMP2*(Z(L)-FXY(L)) + 40 CONTINUE +C + ZDOTZ = DOTPRD(Z,Z,WT,NEQN) +C + RETURN + END + DOUBLE PRECISION FUNCTION DOTPRD(U,V,WT,NEQ) +C************************************************ +C**** NOT A DESIGNATED USER-CALLABLE ROUTINE **** +C************************************************ +C +C Purpose: To compute a weighted Euclidean dot (inner) product of +C two vectors. +C +C Input: U(*), V(*), WT(*), NEQ +C Output: the result DOTPRD is returned via the subprogram name +C +C Comments: +C ========= +C The vectors U(*), V(*), and WT(*) are of length NEQ. The components +C of WT(*) are weights that must be non-zero. +C +C .. Scalar Arguments .. + INTEGER NEQ +C .. Array Arguments .. + DOUBLE PRECISION U(*), V(*), WT(*) +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D0) +C .. Local Scalars .. + DOUBLE PRECISION SUM + INTEGER L +C .. Executable Statements .. +C + SUM = ZERO + DO 20 L = 1, NEQ + SUM = SUM + (U(L)/WT(L))*(V(L)/WT(L)) + 20 CONTINUE +C + DOTPRD = SUM +C + RETURN + END + SUBROUTINE SOFTFL(ASK,ON) +C +C Purpose: To prevent a program STOP after a "catastrophic" +C failure when using a routine from RKSUITE. +C +C Input: ASK +C Input/output: ON +C +C Comments: +C ========= +C When a "catastrophic" failure is detected, the default action of +C RKSUITE is to write an explanation to the standard output channel, +C OUTCH, and STOP. This subroutine can be used to prevent the STOP and +C so allow the main program to continue. To do this, you call SOFTFL with +C ASK = .FALSE. and ON = .TRUE. You must then call the subroutine CHKFL +C after every call to a user-callable routine in RKSUITE to check whether +C a catastrophic error occurred and take appropriate action if it did. Of +C course, you may call SETUP at any time to start a new problem, but calling +C any other user-callable routine in RKSUITE after a catastrophic error will +C lead to a STOP (even when "soft failure" has been set "on"). +C +C When ON is set by a call to SOFTFL with ASK = .FALSE., the value of ON +C is SAVEd. The subroutine RKMSG in RKSUITE calls SOFTFL with ASK = .TRUE. +C to find out the SAVEd value of ON. +C +C .. Scalar Arguments .. + LOGICAL ASK, ON +C .. Local Scalars .. + LOGICAL SOFT +C .. Save statement .. + SAVE SOFT +C .. Data statements .. + DATA SOFT/.FALSE./ +C .. Executable Statements .. +C + IF (ASK) THEN + ON = SOFT + ELSE + SOFT = ON + END IF +C + RETURN + END + SUBROUTINE CHKFL(ASK,ERROR) +C +C Purpose: Enquiry routine used in conjunction with SOFTFL. +C Reports whether a "catastrophic" error was detected. +C +C Input: ASK +C Input/output: ERROR +C +C Comments: +C ========= +C When a "catastrophic" failure is detected, the default action of +C RKSUITE is to write an explanation to the standard output channel, +C OUTCH, and STOP. SOFTFL can be used to prevent the STOP and so +C allow the main program to continue. It is then necessary to call +C CHKFL with ASK = .TRUE. after every call to a user-callable routine +C in RKSUITE to check whether a catastrophic error occurred and take +C appropriate action if it did. If there was a catastrophic error, +C ERROR is returned .TRUE. Of course, you may call SETUP at any time +C to start a new problem, but calling any other user-callable routine +C in RKSUITE after a catastrophic error will lead to a STOP (even when +C "soft failure" has been set "on"). +C +C When a catastrophic failure (IER = 911) is detected in one of +C the routines in RKSUITE, it calls CHKFL with ASK = .FALSE. and +C ERROR = .TRUE. This value of ERROR is SAVEd. +C +C .. Scalar Arguments .. + LOGICAL ASK, ERROR +C .. Local Scalars .. + LOGICAL SAVERR +C .. Save statement .. + SAVE SAVERR +C .. Data statements .. + DATA SAVERR/.FALSE./ +C .. Executable Statements .. +C + IF (ASK) THEN + ERROR = SAVERR + ELSE + SAVERR = ERROR + END IF +C + RETURN + END diff --git a/rksuite/templates b/rksuite/templates new file mode 100644 index 0000000..3122f80 --- /dev/null +++ b/rksuite/templates @@ -0,0 +1,1837 @@ +# to unbundle, sh this file (in an empty directory) +echo tmpl1.out 1>&2 +sed >tmpl1.out <<'//GO.SYSIN DD tmpl1.out' 's/^-//' +- +-Template 1a with METHOD = 2 +- +- t y true y +- +- 0.000 0.0000 0.0000 +- 1.0000 1.0000 +- +- 0.785 0.7071 0.7071 +- 0.7071 0.7071 +- +- 1.571 1.0000 1.0000 +- 0.0000 0.0000 +- +- 2.356 0.7071 0.7071 +- -0.7071 -0.7071 +- +- 3.142 0.0000 0.0000 +- -1.0000 -1.0000 +- +- 3.927 -0.7071 -0.7071 +- -0.7071 -0.7071 +- +- 4.712 -1.0000 -1.0000 +- 0.0000 0.0000 +- +- 5.498 -0.7071 -0.7071 +- 0.7071 0.7071 +- +- 6.283 0.0000 0.0000 +- 1.0000 1.0000 +- +- YMAX(L) +- +- 1.00E+00 +- 1.00E+00 +- +-The cost of the integration in evaluations of F is 109 +- +-******************************************************************************* +- +-Template 1a with METHOD = 1 +- +- t y true y +- +- 0.000 0.0000 0.0000 +- 1.0000 1.0000 +- +- 0.785 0.7071 0.7071 +- 0.7071 0.7071 +- +- 1.571 1.0000 1.0000 +- 0.0000 0.0000 +- +- 2.356 0.7071 0.7071 +- -0.7071 -0.7071 +- +- 3.142 0.0000 0.0000 +- -0.9999 -1.0000 +- +- 3.927 -0.7070 -0.7071 +- -0.7070 -0.7071 +- +- 4.712 -0.9999 -1.0000 +- 0.0000 0.0000 +- +- 5.498 -0.7070 -0.7071 +- 0.7070 0.7071 +- +- 6.283 0.0000 0.0000 +- 0.9998 1.0000 +- +- YMAX(L) +- +- 1.00E+00 +- 1.00E+00 +- +-The cost of the integration in evaluations of F is 292 +- +-******************************************************************************* +- +-Template 1a with METHOD = 3 +- +- t y true y +- +- 0.000 0.0000 0.0000 +- 1.0000 1.0000 +- +- 0.785 0.7071 0.7071 +- 0.7071 0.7071 +- +- 1.571 1.0000 1.0000 +- 0.0000 0.0000 +- +- 2.356 0.7071 0.7071 +- -0.7071 -0.7071 +- +- 3.142 0.0000 0.0000 +- -1.0000 -1.0000 +- +- 3.927 -0.7071 -0.7071 +- -0.7071 -0.7071 +- +- 4.712 -1.0000 -1.0000 +- 0.0000 0.0000 +- +- 5.498 -0.7071 -0.7071 +- 0.7071 0.7071 +- +- 6.283 0.0000 0.0000 +- 1.0000 1.0000 +- +- YMAX(L) +- +- 1.00E+00 +- 1.00E+00 +- +-The cost of the integration in evaluations of F is 105 +- +-******************************************************************************* +- +-Template 1b with METHOD = 2 +- +- t y true y +- +- 0.000 0.0000 0.0000 +- 1.0000 1.0000 +- +- 0.785 0.7071 0.7071 +- 0.7071 0.7071 +- +- 1.571 1.0000 1.0000 +- 0.0000 0.0000 +- +- 2.356 0.7071 0.7071 +- -0.7071 -0.7071 +- +- 3.142 0.0000 0.0000 +- -1.0000 -1.0000 +- +- 3.927 -0.7071 -0.7071 +- -0.7071 -0.7071 +- +- 4.712 -1.0000 -1.0000 +- 0.0000 0.0000 +- +- 5.498 -0.7071 -0.7071 +- 0.7071 0.7071 +- +- 6.283 0.0000 0.0000 +- 1.0000 1.0000 +- +- YMAX(L) +- +- 1.00E+00 +- 1.00E+00 +- +-The tolerance was 5.00E-05 +-The worst global error observed was 4.13E-05. (It occurred at 6.16E+00.) +-The RMS errors in the individual components were: +- 1.84E-05 +- 1.67E-05 +- +-The cost of the integration in evaluations of F was 249 +- +-******************************************************************************* +- +-Template 1b with METHOD = 1 +- +- t y true y +- +- 0.000 0.0000 0.0000 +- 1.0000 1.0000 +- +- 0.785 0.7071 0.7071 +- 0.7071 0.7071 +- +- 1.571 1.0000 1.0000 +- 0.0000 0.0000 +- +- 2.356 0.7071 0.7071 +- -0.7071 -0.7071 +- +- 3.142 0.0000 0.0000 +- -0.9999 -1.0000 +- +- 3.927 -0.7070 -0.7071 +- -0.7070 -0.7071 +- +- 4.712 -0.9999 -1.0000 +- 0.0000 0.0000 +- +- 5.498 -0.7070 -0.7071 +- 0.7070 0.7071 +- +- 6.283 0.0000 0.0000 +- 0.9998 1.0000 +- +- YMAX(L) +- +- 1.00E+00 +- 1.00E+00 +- +-The tolerance was 5.00E-05 +-The worst global error observed was 8.81E-04. (It occurred at 6.30E+00.) +-The RMS errors in the individual components were: +- 1.53E-04 +- 1.22E-04 +- +-The cost of the integration in evaluations of F was 1120 +- +-******************************************************************************* +- +-Template 1b with METHOD = 3 +- +- t y true y +- +- 0.000 0.0000 0.0000 +- 1.0000 1.0000 +- +- 0.785 0.7071 0.7071 +- 0.7071 0.7071 +- +- 1.571 1.0000 1.0000 +- 0.0000 0.0000 +- +- 2.356 0.7071 0.7071 +- -0.7071 -0.7071 +- +- 3.142 0.0000 0.0000 +- -1.0000 -1.0000 +- +- 3.927 -0.7071 -0.7071 +- -0.7071 -0.7071 +- +- 4.712 -1.0000 -1.0000 +- 0.0000 0.0000 +- +- 5.498 -0.7071 -0.7071 +- 0.7071 0.7071 +- +- 6.283 0.0000 0.0000 +- 1.0000 1.0000 +- +- YMAX(L) +- +- 1.00E+00 +- 1.00E+00 +- +-The tolerance was 5.00E-05 +-The worst global error observed was 5.13E-08. (It occurred at 6.28E+00.) +-The RMS errors in the individual components were: +- 2.27E-08 +- 1.71E-08 +- +-The cost of the integration in evaluations of F was 313 +//GO.SYSIN DD tmpl1.out +echo tmpl1a.f 1>&2 +sed >tmpl1a.f <<'//GO.SYSIN DD tmpl1a.f' 's/^-//' +-C +-C Template 1a +-C +-C This template comes in two variants, 1a and 1b, in files tmpl1a.for and +-C tmpl1b.for, respectively. The variant 1b differs only in that the true, +-C or global, error of the integration in 1a is assessed. Output from both +-C variants run with all three methods is found in the file tmpl1.out. +-C +-C Problem: Compute about four correct figures in the solution of +-C +-C y'' = -y +-C +-C on the range [0,2*pi] at intervals of length pi/4, given +-C that y(0)=0, y'(0)=1. +-C +-C Solution: Let y1 = y and y2 = y' to obtain the first order system +-C +-C y1' = y2 with initial values y1 = 0 +-C y2' = - y1 y2 = 1 +-C +-C This is a "Usual Task" that is appropriately solved with UT. +-C Although the code controls the local error rather than the true +-C error, it is "tuned" so that the true error will be comparable to +-C the local error tolerance for typical problems. Thus a relative +-C error tolerance TOL of 5.0D-5 is appropriate. In this range of +-C tolerances, METHOD = 2 is likely to be the most efficient choice. +-C The solution components are expected to get as large as 1.0D0. +-C With this in mind, solution components smaller than, say, 1.0D-10 +-C are not very interesting, and requiring five correct figures then +-C is not worth the cost. For this reason, the threshold values are +-C specified as THRES(L) = 1.0D-10 for L = 1,2. When solution +-C component L is smaller than this threshold, the code will control +-C the local error to be no more than TOL*THRES(L) = 5.0D-15. Error +-C and warning messages, if any, will be printed out. Answers will +-C be computed at equally spaced points, and the true values of y +-C and y' will be printed out for comparison. +-C +-C NOTES: Typically problems are solved for a number of tolerances, initial +-C conditions, intervals, parameter values, ... . A prudent person +-C would make at least one run with global error assessment as a +-C spot check on the reliability of the results. Variant 1b shows +-C how to do this. +-C +-C For TOL in this range, METHOD = 2 is generally the most efficient +-C choice. Indeed, for this specific problem and tolerance (and a +-C specific computer, precision, compiler, ... ), the results found +-C in tmpl1.out show that the cost with METHOD = 2 is 109 calls to +-C the subroutine F, with METHOD = 1 it is 292 calls, and with +-C METHOD = 3 it is 105 calls. At relaxed tolerances, METHOD = 1 is +-C generally the most efficient choice, and at stringent tolerances, +-C METHOD = 3 is generally the most efficient. +-C +-C In typical use of UT, the cost is scarcely affected by the +-C number of answers, but when a "large" number of answers is +-C required, this is not true of METHOD = 3. In such a situation +-C its cost is proportional to the number of answers. +-C +-C Working storage must be provided in the array WORK(*) of length +-C LENWRK. Because storage is no problem with only NEQ = 2 +-C equations, LENWRK is taken here to be 32*NEQ, enough to handle +-C all three methods with and without global error assessment. +-C +-C .. Parameters .. +- INTEGER NEQ, LENWRK, METHOD +- PARAMETER (NEQ=2,LENWRK=32*NEQ,METHOD=2) +- DOUBLE PRECISION ZERO, ONE, TWO, FOUR +- PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,FOUR=4.0D0) +-C .. Local Scalars .. +- DOUBLE PRECISION HNEXT, HSTART, PI, T, TEND, TINC, +- & TLAST, TOL, TSTART, TWANT, WASTE +- INTEGER L, NOUT, STPCST, STPSOK, TOTF, UFLAG +- LOGICAL ERRASS, MESAGE +-C .. Local Arrays .. +- DOUBLE PRECISION THRES(NEQ), WORK(LENWRK), Y(NEQ), YMAX(NEQ), +- & YP(NEQ), YSTART(NEQ) +-C .. External Subroutines .. +- EXTERNAL F, SETUP, STAT, UT +-C .. Intrinsic Functions .. +- INTRINSIC ATAN, COS, SIN +-C .. Executable Statements .. +-C +-C Set the initial conditions. Note that TEND is taken well past +-C the last output point, TLAST. When this is possible, and it +-C usually is, it is good practice. +-C +- TSTART = ZERO +- YSTART(1) = ZERO +- YSTART(2) = ONE +- PI = FOUR*ATAN(ONE) +- TLAST = TWO*PI +- TEND = TLAST + PI +-C +-C Initialize output. +-C +- WRITE (*,'(A,I10)') ' Template 1a with METHOD = ', METHOD +- WRITE (*,'(/A/)') ' t y true y ' +- WRITE (*,'(1X,F6.3,3X,F9.4,3X,F9.4)') +- & TSTART, YSTART(1), SIN(TSTART) +- WRITE (*,'(1X,9X,F9.4,3X,F9.4/)') YSTART(2), COS(TSTART) +-C +-C Set error control parameters. +-C +- TOL = 5.0D-5 +- DO 20 L = 1, NEQ +- THRES(L) = 1.0D-10 +- 20 CONTINUE +-C +-C Call the setup routine. Because messages are requested, MESAGE = .TRUE., +-C there is no need later to test values of flags and print out explanations. +-C In this variant no error assessment is done, so ERRASS is set .FALSE.. +-C By setting HSTART to zero, the code is told to find a starting (initial) +-C step size automatically . +-C +- MESAGE = .TRUE. +- ERRASS = .FALSE. +- HSTART = ZERO +- CALL SETUP(NEQ,TSTART,YSTART,TEND,TOL,THRES,METHOD,'Usual Task', +- & ERRASS,HSTART,WORK,LENWRK,MESAGE) +-C +-C Compute answers at NOUT equally spaced output points. It is good +-C practice to code the calculation of TWANT so that the last value +-C is exactly TLAST. +-C +- NOUT = 8 +- TINC = (TLAST-TSTART)/NOUT +-C +- DO 40 L = 1, NOUT +- TWANT = TLAST + (L-NOUT)*TINC +- CALL UT(F,TWANT,T,Y,YP,YMAX,WORK,UFLAG) +-C +- IF (UFLAG.GT.2) GO TO 60 +-C +-C Success. T = TWANT. Output computed and true solution components. +- WRITE (*,'(1X,F6.3,3X,F9.4,3X,F9.4)') T, Y(1), SIN(T) +- WRITE (*,'(1X,9X,F9.4,3X,F9.4/)') Y(2), COS(T) +- 40 CONTINUE +-C +-C The integration is complete or has failed in a way reported in a +-C message to the standard output channel. +- 60 CONTINUE +-C +-C YMAX(L) is the largest magnitude computed for the solution component +-C Y(L) in the course of the integration from TSTART to the last T. It +-C is used to decide whether THRES(L) is reasonable and to select a new +-C THRES(L) if it is not. +-C +- WRITE (*,'(A/)') ' YMAX(L) ' +- DO 80 L = 1, NEQ +- WRITE (*,'(13X,1PE8.2)') YMAX(L) +- 80 CONTINUE +-C +-C The subroutine STAT is used to obtain some information about the progress +-C of the integration. TOTF is the total number of calls to F made so far +-C in the integration; it is a machine-independent measure of work. At present +-C the integration is finished, so the value printed out refers to the overall +-C cost of the integration. +-C +- CALL STAT(TOTF,STPCST,WASTE,STPSOK,HNEXT) +- WRITE (*,'(/A,I10)') +- & ' The cost of the integration in evaluations of F is', TOTF +-C +- STOP +- END +- SUBROUTINE F(T,Y,YP) +-C .. Scalar Arguments .. +- DOUBLE PRECISION T +-C .. Array Arguments .. +- DOUBLE PRECISION Y(*), YP(*) +-C .. Executable Statements .. +- YP(1) = Y(2) +- YP(2) = -Y(1) +- RETURN +- END +//GO.SYSIN DD tmpl1a.f +echo tmpl1b.f 1>&2 +sed >tmpl1b.f <<'//GO.SYSIN DD tmpl1b.f' 's/^-//' +-C +-C Template 1b +-C +-C This template comes in two variants, 1a and 1b, in files tmpl1a.for and +-C tmpl1b.for, respectively. The variant 1b differs only in that the true, +-C or global, error of the integration in 1a is assessed. Output from both +-C variants run with all three methods is found in the file tmpl1.out. +-C +-C In this variant there is no need to repeat the statement of the problem +-C and the formulation of its solution since it differs only in that global +-C error assessment is done. To emphasize what is different in this variant, +-C all comments not specifically related to the matter have been removed (a +-C practice not to be imitated). +-C +-C Although you might well prefer an estimate of the global error in the +-C approximate solution at TWANT, and the code does have such an estimate at +-C its disposal, it is not made available to you because it is very difficult +-C to obtain a reliable estimate of the global error at a single point. This +-C is easy to understand near a change of sign of the error, but at crude +-C tolerances and at limiting precision and when the problem is not smooth, +-C methods for estimation of global error may break down. Because an +-C assessment of the general size of the global error in the course of an +-C integration can be obtained with much greater reliability at acceptable +-C cost than an estimate at any one point, this is what is provided. A +-C reliable global error assessment is relatively expensive, particularly for +-C METHOD = 1 because it is normally used only at crude tolerances and it +-C is difficult to get a reliable assessment then. The assessment costs +-C roughly double the cost of the integration itself for METHOD = 2 or 3, +-C and triple for METHOD = 1. +-C +-C After any return from UT with the integration advanced to T, the subroutine +-C GLBERR can be called to obtain an assessment of the global error. Two kinds +-C of assessment are provided. An array RMS(*) of length NEQ contains the +-C estimated root-mean-square error in each solution component. This average +-C is over all solution values from the given initial value through the last +-C computed value. (UT may have advanced the integration past your last TWANT +-C and obtained a result there by interpolation, so the average can be over +-C values past TWANT.) A scalar ERRMAX provides the largest error seen in any +-C solution component at any step of the integration so far. The scalar +-C TERRMAX reports where the value ERRMAX was attained. All errors are +-C measured with the same weights used in the integration so that they may +-C be compared with the local error tolerance TOL. +-C +-C For the simple example problem of this template, the true solution is +-C readily available. The output of variant 1a compares the computed to the +-C true solutions at selected points. Examination of the file tmpl1.out +-C provided shows that the global error assessments of variant 1b are in +-C agreement with these true errors at individual output points. With +-C METHOD = 2, the global error is quite closely related to the local error +-C tolerance TOL. METHOD = 1 has a global error that is somewhat larger than +-C TOL. METHOD = 3 has a global error that is considerably smaller than TOL. +-C Unlike the other two methods, this one does not have an interpolation +-C capability. This particular problem is sufficiently easy for the method +-C and the output points are sufficiently close to one another that the step +-C size must be shortened to obtain solutions at the specified output points. +-C Reducing the step size for this reason results in more accuracy (and a +-C greater cost). +-C +-C Global error assessment requires some storage. Here the amount of +-C storage, LENWRK, allocated in WORK(*) is the same as in variant 1a +-C because it was taken there to be enough for all three methods with +-C and without global error assessment. +-C +- INTEGER NEQ, LENWRK, METHOD +- PARAMETER (NEQ=2,LENWRK=32*NEQ,METHOD=2) +- DOUBLE PRECISION ZERO, ONE, TWO, FOUR +- PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,FOUR=4.0D0) +- DOUBLE PRECISION HNEXT, HSTART, PI, T, TEND, TINC, +- & TLAST, TOL, TSTART, TWANT, WASTE +- INTEGER L, NOUT, STPCST, STPSOK, TOTF, UFLAG +- LOGICAL ERRASS, MESAGE +- DOUBLE PRECISION THRES(NEQ), WORK(LENWRK), Y(NEQ), YMAX(NEQ), +- & YP(NEQ), YSTART(NEQ) +-C +-C Some additional quantities must be declared for global error assessment. +-C +- DOUBLE PRECISION ERRMAX, TERRMX +- DOUBLE PRECISION RMSERR(NEQ) +-C +- EXTERNAL F, SETUP, STAT, UT +- INTRINSIC ATAN, COS, SIN +-C +- TSTART = ZERO +- YSTART(1) = ZERO +- YSTART(2) = ONE +- PI = FOUR*ATAN(ONE) +- TLAST = TWO*PI +- TEND = TLAST + PI +-C +- WRITE (*,'(A,I10)') ' Template 1b with METHOD = ', METHOD +- WRITE (*,'(/A/)') ' t y true y ' +- WRITE (*,'(1X,F6.3,3X,F9.4,3X,F9.4)') +- & TSTART, YSTART(1), SIN(TSTART) +- WRITE (*,'(1X,9X,F9.4,3X,F9.4/)') YSTART(2), COS(TSTART) +-C +- TOL = 5.0D-5 +- DO 20 L = 1, NEQ +- THRES(L) = 1.0D-10 +- 20 CONTINUE +- MESAGE = .TRUE. +-C +-C In this variant error assessment is desired, so ERRASS is set .TRUE. +-C in the call to the setup routine. +-C +- ERRASS = .TRUE. +- HSTART = ZERO +- CALL SETUP(NEQ,TSTART,YSTART,TEND,TOL,THRES,METHOD,'Usual Task', +- & ERRASS,HSTART,WORK,LENWRK,MESAGE) +-C +- NOUT = 8 +- TINC = (TLAST-TSTART)/NOUT +-C +- DO 40 L = 1, NOUT +- TWANT = TLAST + (L-NOUT)*TINC +- CALL UT(F,TWANT,T,Y,YP,YMAX,WORK,UFLAG) +-C +-C A global error assessment is useless unless it is reliable, so the code +-C monitors computation of the assessment for credibility. If the code has +-C any doubts about the reliability of the assessment, it will return with +-C a message to this effect and UFLAG set to 6. An attempt to continue +-C integrating after such a return is a fatal error. As coded, the +-C integration is terminated when UFLAG = 6 and the global error is assessed +-C up to last point where the code believes the assessment to be reliable. +-C +- IF (UFLAG.GT.2) GO TO 60 +-C +- WRITE (*,'(1X,F6.3,3X,F9.4,3X,F9.4)') T, Y(1), SIN(T) +- WRITE (*,'(1X,9X,F9.4,3X,F9.4/)') Y(2), COS(T) +- 40 CONTINUE +-C +- 60 CONTINUE +-C +- WRITE (*,'(A/)') ' YMAX(L) ' +- DO 80 L = 1, NEQ +- WRITE (*,'(13X,1PE8.2)') YMAX(L) +- 80 CONTINUE +-C +-C The assessment is obtained by a call to GLBERR. +-C +- CALL GLBERR(RMSERR,ERRMAX,TERRMX,WORK) +- WRITE (*,'(/A,1PE9.2)') +- &' The tolerance was ',TOL +- WRITE (*,'(A,1PE9.2,A,1PE9.2,A)') +- &' The worst global error observed was ',ERRMAX, +- &'. (It occurred at ',TERRMX,'.)' +- WRITE (*,'(A)') +- &' The RMS errors in the individual components were:' +- DO 100 L = 1,NEQ +- WRITE (*,'(50X,1PE9.2)') RMSERR(L) +- 100 CONTINUE +-C +- CALL STAT(TOTF,STPCST,WASTE,STPSOK,HNEXT) +- WRITE (*,'(/A,I10)') +- &' The cost of the integration in evaluations of F was', TOTF +-C +- STOP +- END +- SUBROUTINE F(T,Y,YP) +- DOUBLE PRECISION T +- DOUBLE PRECISION Y(*), YP(*) +- YP(1) = Y(2) +- YP(2) = -Y(1) +- RETURN +- END +//GO.SYSIN DD tmpl1b.f +echo tmpl2.out 1>&2 +sed >tmpl2.out <<'//GO.SYSIN DD tmpl2.out' 's/^-//' +- +-Template 2a with METHOD = 3 +- +- YMAX(L) +- +- 1.90E+00 +- 4.36E-01 +- 2.29E+00 +- 4.36E+00 +- +-The integration reached 2.00E+01 +-The cost of the integration in calls to F was 4631 +-The number of calls to F per step is 13 +-The fraction of failed steps was 0.02 +-The number of accepted steps was 344 +- +-At t = 20, the error is 1.22E-09 +-The tolerance is 1.00E-10 +- +-******************************************************************************* +- +-Template 2a with METHOD = 2 +- +- +-** +-** Approximately 5000 function evaluations have been +-** used to compute the solution since the integration +-** started or since this message was last printed. +-** +-** Warning from routine CT with flag set 3. +-** You can continue integrating this problem. +-** +- YMAX(L) +- +- 1.90E+00 +- 4.36E-01 +- 2.29E+00 +- 4.36E+00 +- +-The integration reached 2.00E+01 +-The cost of the integration in calls to F was 8091 +-The number of calls to F per step is 7 +-The fraction of failed steps was 0.00 +-The number of accepted steps was 1146 +- +-At t = 20, the error is 9.22E-10 +-The tolerance is 1.00E-10 +- +-******************************************************************************* +- +-Template 2b with METHOD = 3 +- +- YMAX(L) +- +- 1.90E+00 +- 4.36E-01 +- 2.29E+00 +- 4.36E+00 +- +-The integration reached 2.00E+01 +-The cost of the integration in calls to F was 13575 +-The number of calls to F per step is 13 +-The fraction of failed steps was 0.02 +-The number of accepted steps was 344 +- +-At t = 20, the error is 1.22E-09 +-The tolerance is 1.00E-10 +-The worst global error observed was 6.28E-07. (It occurred at 1.89E+01.) +-The RMS errors in the individual components were: +- 3.13E-08 +- 6.00E-08 +- 5.94E-08 +- 6.14E-09 +- +-******************************************************************************* +- +-Template 2b with METHOD = 2 +- +- +-** +-** Approximately 5000 function evaluations have been +-** used to compute the solution since the integration +-** started or since this message was last printed. +-** +-** Warning from routine CT with flag set 3. +-** You can continue integrating this problem. +-** +- YMAX(L) +- +- 1.90E+00 +- 4.36E-01 +- 2.29E+00 +- 4.36E+00 +- +-The integration reached 2.00E+01 +-The cost of the integration in calls to F was 24135 +-The number of calls to F per step is 7 +-The fraction of failed steps was 0.00 +-The number of accepted steps was 1146 +- +-At t = 20, the error is 9.22E-10 +-The tolerance is 1.00E-10 +-The worst global error observed was 2.30E-06. (It occurred at 1.88E+01.) +-The RMS errors in the individual components were: +- 5.67E-08 +- 1.03E-07 +- 1.03E-07 +- 5.46E-09 +//GO.SYSIN DD tmpl2.out +echo tmpl2a.f 1>&2 +sed >tmpl2a.f <<'//GO.SYSIN DD tmpl2a.f' 's/^-//' +-C +-C Template 2a +-C +-C This template comes in two variants, 2a and 2b, in files tmpl2a.for and +-C tmpl2b.for, respectively. The variant 2b differs only in that the true, +-C or global, error of the integration in 2a is assessed. The output to the +-C standard output channel from both variants run with both METHODs 2 and 3 +-C is found in the file tmpl2.out. +-C +-C Problem: Integrate a two body problem. The equations for the coordinates +-C (x(t),y(t)) of one body as functions of time t in a suitable +-C frame of reference are +-C +-C x'' = - x/r**3, +-C y'' = - y/r**3, where r = SQRT(x**2 + y**2). +-C +-C The initial conditions lead to elliptic motion with eccentricity +-C ECC. This parameter will be taken to be 0.9. +-C +-C x(0) = 1-ECC, x'(0) = 0, +-C y(0) = 0, y'(0) = SQRT((1+ECC)/(1-ECC)). +-C +-C An accurate solution that shows the general behavior of the +-C orbit is desired. The coordinates will be returned at every +-C time step in [0,20]. This is a standard test problem for which +-C there is a semi-analytical solution. It will be compared to the +-C computed solution at the end of the interval. +-C +-C Solution: Substitute y1 = x, y2 = y, y3 = x', and y4 = y' to obtain +-C +-C y1' = y3, y1(0) = 1-ECC, +-C y2' = y4, y2(0) = 0, +-C y3' = - y1/r**3, y3(0) = 0, +-C y4' = - y2/r**3, y4(0) = SQRT((1+ECC)/(1-ECC)), +-C where +-C r = SQRT(y1**2 + y2**2). +-C +-C Since it is the general behavior of the solution that is desired, +-C it is best to let the integrator choose where to provide answers. +-C It will produce answers more frequently where the solution +-C changes more rapidly. Because the solution is inspected at +-C every step, the task is a "Complex Task" that is solved with CT. +-C +-C On physical grounds the solution is expected to be somewhat +-C unstable when one body approaches the other. To obtain an +-C accurate solution, a stringent relative error tolerance should +-C be imposed -- TOL = 1.0D-10 will be used. At a tolerance this +-C stringent the highest order pair, METHOD = 3, is likely to be +-C the most efficient choice. This method is inefficient when it +-C is to produce answers at a great many specific points. It is +-C most effective when used as in this template. The solution +-C components are expected to be of order 1, so threshold values +-C THRES(*) = 1.0D-13 are reasonable. When a solution component is +-C smaller in magnitude than this threshold, the code will control +-C the local error to be no more than TOL*THRES(L) = 1.0D-23. The +-C reasonableness of this choice will be monitored by printing out +-C the maximum value seen for each solution component in the course +-C of the integration. Error and warning messages, if any, will be +-C printed out. +-C +-C This is the standard test problem D5 of T.E. Hull, W.H. Enright, +-C B.M. Fellen, and A.E. Sedgwick, "Comparing Numerical Methods +-C for Ordinary Differential Equations," SIAM Journal on Numerical +-C Analysis, Vol. 9, pp. 603-637, 1972. The analytical solution +-C in terms of the numerical solution of Kepler's equation can be +-C found there as well as in most discussions of the two body +-C problem. The results for the particular choice of eccentricity, +-C initial conditions, and interval of this template are provided +-C here in a DATA statement. +-C +-C NOTES: Typically problems are solved for a number of tolerances, initial +-C conditions, intervals, parameter values, ... . A prudent person +-C would make at least one run with global error assessment as a +-C spot check on the reliability of the results. Variant 2b shows +-C how to do this. +-C +-C For TOL in this range, METHOD = 3 is generally the most efficient +-C choice. Indeed, for this specific problem and tolerance (and a +-C specific computer, precision, compiler, ... ), the results found +-C in tmpl2.out show that the cost with METHOD = 3 is 4631 calls to +-C the subroutine F. With METHOD = 2 the cost is 8091 calls, so +-C the higher order pair is quite advantageous at a tolerance as +-C stringent as TOL = 1.0D-10. Of course, one should not even +-C consider using METHOD = 1 at tolerances this stringent. +-C +-C With METHOD = 3, the template writes to an output file results +-C at 344 steps, which is more than adequate to see how the solution +-C components behave. The global error at the end of the run is about +-C 1.2D-9, rather bigger than the local error tolerance TOL. This +-C illustrates the point that at best one can anticipate global +-C errors comparable to the tolerance. In point of fact, this +-C problem is unstable at some points of the integration and the +-C global error assessment of variant 2b reveals that the worst +-C global error is considerably worse than the error at the end +-C -- an example of the value of the global error assessment +-C capability. +-C +-C Working storage must be provided in the array WORK(*) of length +-C LENWRK. Because storage is no problem with only NEQ = 4 +-C equations, LENWRK is taken here to be 32*NEQ, enough to handle +-C all three methods with and without global error assessment. +-C +-C .. Parameters .. +- INTEGER NEQ, METHOD, LENWRK, OUTFIL +- PARAMETER (NEQ=4,METHOD=3,LENWRK=32*NEQ,OUTFIL=9) +- DOUBLE PRECISION ECC, ZERO, ONE +- PARAMETER (ECC=0.9D0,ZERO=0.0D0,ONE=1.0D0) +-C .. Local Scalars .. +- DOUBLE PRECISION ERROR, HNEXT, HSTART, TEND, TNOW, +- & TOL, TSTART, WASTE, WEIGHT +- INTEGER CFLAG, CFLAG3, L, STPCST, STPSOK, TOTF +- LOGICAL ERRASS, MESAGE +-C .. Local Arrays .. +- DOUBLE PRECISION THRES(NEQ), TRUY(NEQ), WORK(LENWRK), YMAX(NEQ), +- & YNOW(NEQ), YPNOW(NEQ), YSTART(NEQ) +-C .. External Subroutines .. +- EXTERNAL CT, F, SETUP, STAT +-C .. Intrinsic Functions .. +- INTRINSIC ABS, MAX, SQRT +-C .. Data statements .. +- DATA TRUY/-1.29526625098758D0, 0.400393896379232D0, +- & -0.67753909247075D0, -0.127083815427869D0/ +-C .. Executable Statements .. +-C +-C Initialize output. +-C +- WRITE (*,'(A,I10/)') ' Template 2a with METHOD = ', METHOD +-C +-C Set initial conditions and the end of the interval of interest. +-C +- TSTART = ZERO +- YSTART(1) = ONE - ECC +- YSTART(2) = ZERO +- YSTART(3) = ZERO +- YSTART(4) = SQRT((ONE+ECC)/(ONE-ECC)) +- TEND = 20.0D0 +-C +-C Because the solution components may be computed at many points, they are +-C written to a file on unit OUTFIL. Subsequently, the results can be studied, +-C plotted, or manipulated as necessary. Naming of files is system-dependent, +-C so the name here, RESULT, may need to be changed. For simplicity, list- +-C directed output is used. The data could be manipulated later as required +-C by, e.g., a plot package, or the WRITE statements in this template could be +-C altered so as to output the results in the desired form. Begin by writing +-C the initial values to RESULT. +-C +- OPEN (UNIT=OUTFIL,FILE='RESULT') +- WRITE (OUTFIL,*) TSTART, YSTART(1), YSTART(2), YSTART(3), +- & YSTART(4) +-C +-C To monitor the reasonableness of the choice of THRES(L), the maximum +-C magnitude YMAX(L) of solution component L is computed and returned. +-C It is initialized here. +-C +- DO 20 L = 1, NEQ +- YMAX(L) = ABS(YSTART(L)) +- 20 CONTINUE +-C +-C Set error control parameters. +-C +- TOL = 1.0D-10 +- DO 40 L = 1, NEQ +- THRES(L) = 1.0D-13 +- 40 CONTINUE +-C +-C Call the setup routine. Because messages are requested, MESAGE = .TRUE., +-C there is no need later to test values of flags and print out explanations. +-C In this variant no error assessment is done, so ERRASS is set .FALSE.. +-C By setting HSTART = ZERO, the code is told to find a starting (initial) +-C step size automatically . +-C +- MESAGE = .TRUE. +- ERRASS = .FALSE. +- HSTART = ZERO +- CALL SETUP(NEQ,TSTART,YSTART,TEND,TOL,THRES,METHOD,'Complex Task', +- & ERRASS,HSTART,WORK,LENWRK,MESAGE) +-C +-C Advance the integration one step. Note that messages are written to +-C the standard output channel rather than to the file where the results +-C are being accumulated. The code will not go past the specified TEND. +-C Because it will step to exactly TEND, this fact can be used to terminate +-C the run. +-C +- CFLAG3 = 0 +- 60 CONTINUE +- CALL CT(F,TNOW,YNOW,YPNOW,WORK,CFLAG) +-C +-C Update the maximum magnitudes of the solution components. +- DO 80 L = 1, NEQ +- YMAX(L) = MAX(YMAX(L),ABS(YNOW(L))) +- 80 CONTINUE +-C +- IF (CFLAG.LE.3) THEN +-C +-C Success. Record the results and go on towards TEND. The combination of +-C the tolerance and the length of the interval is sufficiently demanding that +-C the code might return with CFLAG = 3 to report that 5000 calls have been +-C made to the subroutine F. The evaluations in F are not expensive, so +-C three such returns are permitted before terminating the run. +-C +- WRITE (OUTFIL,*) TNOW, YNOW(1), YNOW(2), YPNOW(1), YPNOW(2) +- IF (CFLAG.EQ.3) CFLAG3 = CFLAG3 + 1 +- IF (TNOW.LT.TEND .AND. CFLAG3.LT.3) GO TO 60 +- END IF +- CLOSE (OUTFIL) +-C +-C At the end of the run, the maximum magnitudes of the solution components +-C are reported so that the reasonableness of the threshold values THRES(*) +-C can be checked. +-C +- WRITE (*,'(A/)') ' YMAX(L) ' +- DO 100 L = 1, NEQ +- WRITE (*,'(13X,1PE8.2)') YMAX(L) +- 100 CONTINUE +-C +-C The subroutine STAT is used to obtain some information about the progress +-C of the integration. TOTF is the total number of calls to F made so far +-C in the integration; it is a machine-independent measure of work. At present +-C the integration is finished, so the value printed out refers to the overall +-C cost of the integration. STPCST is the cost in calls to F of a typical +-C step with this method. WASTE is the fraction of steps after the first that +-C were rejected. A "large" value of WASTE is usually the result of a mistake +-C in the coding of F. It can also be the result of a solution component that +-C is not smooth -- singular or with many places where a low order derivative +-C is not continuous. STPSOK is the number of accepted steps. +-C +- CALL STAT(TOTF,STPCST,WASTE,STPSOK,HNEXT) +- WRITE (*,'(/A,1PE10.2,0P/A,I10/A,I10/A,F10.2/A,I10)') +- &' The integration reached ', TNOW, +- &' The cost of the integration in calls to F was', TOTF, +- &' The number of calls to F per step is ', STPCST, +- &' The fraction of failed steps was ', WASTE, +- &' The number of accepted steps was ', STPSOK +-C +-C For this particular problem a semi-analytical solution is available to +-C study the relationship between local error tolerance and true (global) +-C error. The true solution at t = 20 is provided in TRUY(*). If the +-C integration reached this point, the error of the computed solution is +-C computed and returned. To interpret the results properly, the error +-C must be measured in the same way that it is measured in the code. +-C +- IF (TNOW.EQ.TEND) THEN +- ERROR = ZERO +- DO 120 L = 1, NEQ +- WEIGHT = MAX(ABS(YNOW(L)),THRES(L)) +- ERROR = MAX(ERROR,ABS(TRUY(L)-YNOW(L))/WEIGHT) +- 120 CONTINUE +- WRITE (*,'(/A,1PE9.2)') +- &' At t = 20, the error is',ERROR +- WRITE (*,'(A,1PE9.2)') ' The tolerance is ', TOL +- END IF +-C +- STOP +- END +- SUBROUTINE F(T,Y,YP) +-C .. Scalar Arguments .. +- DOUBLE PRECISION T +-C .. Array Arguments .. +- DOUBLE PRECISION Y(*), YP(*) +-C .. Local Scalars .. +- DOUBLE PRECISION R +-C .. Intrinsic Functions .. +- INTRINSIC SQRT +-C .. Executable Statements .. +- R = SQRT(Y(1)**2+Y(2)**2) +- YP(1) = Y(3) +- YP(2) = Y(4) +- YP(3) = -Y(1)/R**3 +- YP(4) = -Y(2)/R**3 +- RETURN +- END +//GO.SYSIN DD tmpl2a.f +echo tmpl2b.f 1>&2 +sed >tmpl2b.f <<'//GO.SYSIN DD tmpl2b.f' 's/^-//' +-C +-C Template 2b +-C +-C This template comes in two variants, 2a and 2b, in files tmpl2a.for and +-C tmpl2b.for, respectively. The variant 2b differs only in that the true, +-C or global, error of the integration in 2a is assessed. The output to the +-C standard output channel from both variants run with both METHOD 2 and 3 is +-C found in the file tmpl2.out. +-C +-C In this variant there is no need to repeat the statement of the problem +-C and the formulation of its solution since it differs only in that global +-C error assessment is done. To emphasize what is different in this variant, +-C all comments not specifically related to the matter have been removed (a +-C practice not to be imitated). +-C +-C Although you might well prefer an estimate of the global error in the +-C approximate solution at TNOW, and the code does have such an estimate at +-C its disposal, it is not made available to you because it is very difficult +-C to obtain a reliable estimate of the global error at a single point. This +-C is easy to understand near a change of sign of the error, but at crude +-C tolerances and at limiting precision and when the problem is not smooth, +-C methods for estimation of global error may break down. Because an +-C assessment of the general size of the global error in the course of an +-C integration can be obtained with much greater reliability at acceptable +-C cost than an estimate at any one point, this is what is provided. A +-C reliable global error assessment is relatively expensive, particularly for +-C METHOD = 1 because it is normally used only at crude tolerances and it +-C is difficult to get a reliable assessment then. The assessment costs +-C roughly double the cost of the integration itself for METHOD = 2 or 3, +-C and triple for METHOD = 1. +-C +-C After any return from CT with the integration advanced to TNOW, the +-C subroutine GLBERR can be called to obtain an assessment of the global error. +-C Two kinds of assessment are provided. An array RMS(*) of length NEQ +-C contains the estimated root-mean-square error in each solution component. +-C This average is over all solution values from the given initial value +-C through the last computed value. A scalar ERRMAX provides the largest error +-C seen in any solution component at any step of the integration so far. The +-C scalar TERRMX reports where the value ERRMAX was attained. All errors are +-C measured with the same weights used in the integration so that they may +-C be compared with the local error tolerance TOL. +-C +-C The output of variant 2a compares the computed to the true solution +-C components at the end of the interval of integration. The error at this +-C point is found to be somewhat bigger than the tolerance. However, +-C examination of the file tmpl2.out provided shows that the RMS errors are +-C rather bigger than the error at this one point, and moreover, the worst +-C global error is considerably bigger. This illustrates the fact that +-C global errors can decrease as well as increase in the course of an +-C integration. +-C +-C Global error assessment requires some storage. Here the amount of +-C storage, LENWRK, allocated in WORK(*) is the same as in variant 2a +-C because it was taken there to be enough for all three methods with +-C and without global error assessment. +-C +- INTEGER NEQ, METHOD, LENWRK, OUTFIL +- PARAMETER (NEQ=4,METHOD=3,LENWRK=32*NEQ,OUTFIL=9) +- DOUBLE PRECISION ECC, ZERO, ONE +- PARAMETER (ECC=0.9D0,ZERO=0.0D0,ONE=1.0D0) +- DOUBLE PRECISION ERROR, HNEXT, HSTART, TEND, TNOW, +- & TOL, TSTART, WASTE, WEIGHT +- INTEGER CFLAG, CFLAG3, L, STPCST, STPSOK, TOTF +- LOGICAL ERRASS, MESAGE +- DOUBLE PRECISION THRES(NEQ), TRUY(NEQ), WORK(LENWRK), YMAX(NEQ), +- & YNOW(NEQ), YPNOW(NEQ), YSTART(NEQ) +-C +-C Some additional quantities must be declared for global error assessment. +-C +- DOUBLE PRECISION ERRMAX,TERRMX +- DOUBLE PRECISION RMSERR(NEQ) +-C +- EXTERNAL CT, F, SETUP, STAT +- INTRINSIC ABS, MAX, SQRT +- DATA TRUY/-1.29526625098758D0, 0.400393896379232D0, +- & -0.67753909247075D0, -0.127083815427869D0/ +-C +- WRITE (*,'(A,I10/)') ' Template 2b with METHOD = ', METHOD +-C +- TSTART = ZERO +- YSTART(1) = ONE - ECC +- YSTART(2) = ZERO +- YSTART(3) = ZERO +- YSTART(4) = SQRT((ONE+ECC)/(ONE-ECC)) +- TEND = 20.0D0 +-C +- OPEN (UNIT=OUTFIL,FILE='RESULT') +- WRITE (OUTFIL,*) TSTART, YSTART(1), YSTART(2), YSTART(3), +- & YSTART(4) +-C +- DO 20 L = 1, NEQ +- YMAX(L) = ABS(YSTART(L)) +- 20 CONTINUE +-C +- TOL = 1.0D-10 +- DO 40 L = 1, NEQ +- THRES(L) = 1.0D-13 +- 40 CONTINUE +-C +- MESAGE = .TRUE. +-C +-C In this variant error assessment is desired, so ERRASS is set .TRUE. in +-C the call to the setup routine. +-C +- ERRASS = .TRUE. +- HSTART = ZERO +- CALL SETUP(NEQ,TSTART,YSTART,TEND,TOL,THRES,METHOD,'Complex Task', +- & ERRASS,HSTART,WORK,LENWRK,MESAGE) +-C +- CFLAG3 = 0 +- 60 CONTINUE +- CALL CT(F,TNOW,YNOW,YPNOW,WORK,CFLAG) +-C +- DO 80 L = 1, NEQ +- YMAX(L) = MAX(YMAX(L),ABS(YNOW(L))) +- 80 CONTINUE +-C +-C A global error assessment is useless unless it is reliable, so the code +-C monitors the computation of the assessment for credibility. If the code +-C has any doubts about the reliability of the assessment, it will return +-C with a message to this effect and CFLAG set to 6. An attempt to continue +-C integrating after such a return is a fatal error. When CFLAG = 6 the +-C integration is terminated and the global error is assessed through the +-C last point where the code believes the assessment to be reliable. +-C +- IF (CFLAG.LE.3) THEN +-C +- WRITE (OUTFIL,*) TNOW, YNOW(1), YNOW(2), YPNOW(1), YPNOW(2) +- IF (CFLAG.EQ.3) CFLAG3 = CFLAG3 + 1 +- IF (TNOW.LT.TEND .AND. CFLAG3.LT.3) GO TO 60 +- END IF +- CLOSE (OUTFIL) +-C +- WRITE (*,'(A/)') ' YMAX(L) ' +- DO 100 L = 1, NEQ +- WRITE (*,'(13X,1PE8.2)') YMAX(L) +- 100 CONTINUE +-C +- CALL STAT(TOTF,STPCST,WASTE,STPSOK,HNEXT) +- WRITE (*,'(/A,1PE10.2,0P/A,I10/A,I10/A,F10.2/A,I10)') +- &' The integration reached ', TNOW, +- &' The cost of the integration in calls to F was', TOTF, +- &' The number of calls to F per step is ', STPCST, +- &' The fraction of failed steps was ', WASTE, +- &' The number of accepted steps was ', STPSOK +-C +- IF (TNOW.EQ.TEND) THEN +- ERROR = ZERO +- DO 120 L = 1, NEQ +- WEIGHT = MAX(ABS(YNOW(L)),THRES(L)) +- ERROR = MAX(ERROR,ABS(TRUY(L)-YNOW(L))/WEIGHT) +- 120 CONTINUE +- WRITE (*,'(/A,1PE9.2)') +- &' At t = 20, the error is', ERROR +- WRITE (*,'(A,1PE9.2)') ' The tolerance is ', TOL +- END IF +-C +-C The assessment is obtained by a call to GLBERR. +-C +- CALL GLBERR(RMSERR,ERRMAX,TERRMX,WORK) +- WRITE (*,'(A,1PE9.2,A,1PE9.2,A)') +- &' The worst global error observed was ',ERRMAX, +- &'. (It occurred at ',TERRMX,'.)' +- WRITE (*,'(A)') +- &' The RMS errors in the individual components were:' +- DO 140 L = 1,NEQ +- WRITE (*,'(50X,1PE9.2)') RMSERR(L) +- 140 CONTINUE +-C +- STOP +- END +- SUBROUTINE F(T,Y,YP) +- DOUBLE PRECISION T +- DOUBLE PRECISION Y(*), YP(*) +- DOUBLE PRECISION R +- INTRINSIC SQRT +- R = SQRT(Y(1)**2+Y(2)**2) +- YP(1) = Y(3) +- YP(2) = Y(4) +- YP(3) = -Y(1)/R**3 +- YP(4) = -Y(2)/R**3 +- RETURN +- END +//GO.SYSIN DD tmpl2b.f +echo tmpl3.out 1>&2 +sed >tmpl3.out <<'//GO.SYSIN DD tmpl3.out' 's/^-//' +- +-Template 3a with METHOD = 2 and B = 9.8 +- +- +-The integration reached 6.28E+02 +-The cost of the integration in calls to F was 29366 +-The number of calls to F per step is 7 +-The fraction of failed steps was 0.12 +-The number of accepted steps was 3726 +- +-******************************************************************************* +- +-Template 3a with METHOD = 2 and B = 11.0 +- +- +-The integration reached 6.28E+02 +-The cost of the integration in calls to F was 31161 +-The number of calls to F per step is 7 +-The fraction of failed steps was 0.15 +-The number of accepted steps was 3854 +- +-******************************************************************************* +- +-Template 3b with METHOD = 3 and B = 11.0 +- +-Global error estimation broke down. +- +- +-The tolerance was 1.00E-07 +-The worst global error observed was 6.77E-02. (It occurred at 1.21E+02.) +-The RMS errors in the individual components were: +- 2.92E-03 +- 8.09E-04 +- +-The integration reached 1.21E+02 +-The cost of the integration in calls to F was 34348 +-The number of calls to F per step is 13 +-The fraction of failed steps was 0.16 +-The number of accepted steps was 832 +- +-******************************************************************************* +- +-Template 3b with METHOD = 3 and B = 9.8 +- +- +-The tolerance was 1.00E-07 +-The worst global error observed was 1.13E-04. (It occurred at 8.48E+01.) +-The RMS errors in the individual components were: +- 3.37E-06 +- 5.08E-06 +- +-The integration reached 6.28E+02 +-The cost of the integration in calls to F was 169555 +-The number of calls to F per step is 13 +-The fraction of failed steps was 0.17 +-The number of accepted steps was 4090 +//GO.SYSIN DD tmpl3.out +echo tmpl3a.f 1>&2 +sed >tmpl3a.f <<'//GO.SYSIN DD tmpl3a.f' 's/^-//' +-C +-C Template 3a +-C +-C This template comes in two variants, 3a and 3b, in files tmpl3a.for and +-C tmpl3b.for, respectively. They illustrate different aspects of the RK +-C suite on the same problem. The task could be handled more simply with +-C UT; the purpose of the template is to illustrate how to use CT when more +-C control over the integration is required. Specifically, variant 3a +-C illustrates how to use CT with METHOD = 2 to advance the integration a +-C step at a time and how to use INTRP with this METHOD to get answers at +-C specific points by interpolation. +-C +-C Problem: Integrate a forced Duffing equation that models an electric +-C circuit with a nonlinear inductor. The behavior of solutions +-C depends on the value of a parameter B that governs the size of +-C the forcing term. This problem is discussed at length in F.C. +-C Moon, Chaotic Vibrations, John Wiley & Sons, Inc., New York, +-C 1987; numerical results are reported on p. 272. Written as +-C a first order system, the second order equation is +-C +-C y1' = y2, +-C y2' = - 0.1 y2 - y1**3 + B cos(t). +-C +-C A Poincare map is used to study the qualitative behavior of the +-C solutions. This means that solution values are to be computed +-C at t = 2*pi*k for k = 1,2,...,n and y2(t) plotted against y1(t). +-C +-C Exploration of the qualitative behavior of solutions could lead +-C to integration of the differential equation for a great many +-C initial values. Here the single set of initial values +-C y1(0) = 3.3, y2(0) = -3.3 +-C is considered. It is planned that the integration extend for +-C many multiples of the period 2*pi of the forcing function. +-C The template takes n = 100. To have some accuracy at the end +-C of a "long" integration, it is necessary to specify a moderately +-C stringent tolerance. In this variant TOL is taken to be 1.0D-5. +-C The general scaling of the initial values and the anticipated +-C behavior of the solution components suggest that threshold +-C values of 1.0D-10 on each component might be reasonable. +-C +-C At this tolerance METHOD = 2 is a reasonable choice. Output +-C is desired at specific points. By using INTRP, output this +-C infrequently has no impact on the cost of the integration. +-C +-C The character of the problem depends on the value of B. According +-C to Moon, the solution is periodic when B = 9.8 and becomes +-C chaotic when B is about 10.0. The behavior of the global error +-C is very different in these circumstances. By definition the +-C solution is very sensitive to changes in the initial conditions +-C when there is chaos. This means that it is very difficult to +-C compute accurately a specific solution curve -- the global error +-C must get large rather quickly. Variant 3a takes B = 9.8 so that +-C the solution is periodic. Also included in tmpl3.out is the +-C output when B = 11.0, a chaotic solution. +-C +-C With both variants of the template the integrations are +-C sufficiently expensive that if MESAGE is set .TRUE., there are +-C a considerable number of returns reporting that 5000 function +-C evaluations have been made since the last message. To suppress +-C these messages, MESAGE is set .FALSE. Another purpose of this +-C template is to illustrate the processing of error messages and +-C the decisions that are made at each step of an integration. +-C +-C NOTES: Working storage must be provided in the array WORK(*) of +-C length LENWRK. Although storage is no problem with only +-C NEQ = 2 equations, LENWRK is taken here to be 14*NEQ, +-C the least that can be used in CT with METHOD = 2 when global +-C error assessment is not done (ERRASS = .FALSE.). Storage must +-C also be supplied for interpolation in the array WRKINT(*) of +-C length NINT. The amount depends on the number NWANT of +-C solution components desired. In this template, all the +-C components are approximated so NWANT = NEQ. NINT is taken +-C here to be the minimum needed with this METHOD, namely +-C NEQ+MAX(NEQ,5*NWANT) = 6*NEQ. +-C +-C .. Parameters .. +- INTEGER NEQ, METHOD, NWANT, NINT, +- & LENWRK, OUTFIL, MAXPER +- PARAMETER (NEQ=2,METHOD=2,NWANT=NEQ,NINT=6*NEQ, +- & LENWRK=14*NEQ,OUTFIL=9,MAXPER=100) +- DOUBLE PRECISION ZERO, ONE, FOUR +- PARAMETER (ZERO=0.0D0,ONE=1.0D0,FOUR=4.0D0) +-C .. Local Scalars .. +- DOUBLE PRECISION HNEXT, HSTART, PI, TEND, TNOW, +- & TOL, TOUT, TSTART, TWOPI, WASTE +- INTEGER CFLAG, KOUNTR, L, STPCST, STPSOK, TOTF +- LOGICAL ERRASS, MESAGE +-C .. Local Arrays .. +- DOUBLE PRECISION THRES(NEQ), WORK(LENWRK), WRKINT(NINT), +- & YNOW(NEQ), YOUT(NEQ), YPNOW(NEQ), YPOUT(1), +- & YSTART(NEQ) +-C .. External Subroutines .. +- EXTERNAL CT, F, INTRP, SETUP, STAT +-C .. Scalars in Common .. +- DOUBLE PRECISION B +-C .. Intrinsic Functions .. +- INTRINSIC ATAN +-C .. Common blocks .. +- COMMON /BPARAM/B +-C .. Executable Statements .. +-C +- PI = FOUR*ATAN(ONE) +- TWOPI = PI + PI +-C +-C Set the parameter defining the character of the solutions. +-C +- B = 9.8D0 +-C +-C Initialize output. +-C +- WRITE (*,'(A,I3,A,F5.1/)') +- &' Template 3a with METHOD = ',METHOD,' and B = ', B +-C +-C Set the initial conditions. TEND is well past the last point +-C of interest, MAXPER*2*PI, so that the code can step past this +-C point and obtain the answer there by interpolation. +-C +- TSTART = ZERO +- YSTART(1) = 3.3D0 +- YSTART(2) = -3.3D0 +- TEND = TSTART + MAXPER*TWOPI + TWOPI +-C +-C Because the solution components may be computed at many points, they are +-C written to a file on unit OUTFIL. Subsequently, the results can be studied, +-C plotted, or manipulated as necessary. Naming of files is system-dependent, +-C so the name here, PLOT.DAT, may need to be changed. Begin by writing the +-C initial values to PLOT.DAT in a form suitable for plotting y2 against y1. +-C +- OPEN (UNIT=OUTFIL,FILE='PLOT.DAT') +-C +- WRITE (OUTFIL,'(2E13.5)') YSTART(1), YSTART(2) +-C +-C Set error control parameters. +-C +- TOL = 1.0D-5 +- DO 20 L = 1, NEQ +- THRES(L) = 1.0D-10 +- 20 CONTINUE +-C +-C Call the setup routine. Set MESAGE = .FALSE. because this will be a +-C a relatively expensive integration and it is annoying to be told +-C repeatedly that 5000 function evaluations have been required. The +-C global error is not assessed. Automatic selection of an initial step +-C size is specified by setting HSTART to zero. +-C +- MESAGE = .FALSE. +- ERRASS = .FALSE. +- HSTART = ZERO +- CALL SETUP(NEQ,TSTART,YSTART,TEND,TOL,THRES,METHOD,'Complex Task', +- & ERRASS,HSTART,WORK,LENWRK,MESAGE) +-C +-C KOUNTR counts the number of output points. +-C +- KOUNTR = 1 +- TOUT = TSTART + TWOPI +- 40 CONTINUE +- CALL CT(F,TNOW,YNOW,YPNOW,WORK,CFLAG) +-C +-C Loop until an output point is reached, or the code gets into +-C trouble. Interrogate CFLAG to decide on an appropriate course +-C of action. Because MESAGE = .FALSE., it is necessary to write +-C out an explanation of any trouble except for a catastrophe when an +-C explanation is provided automatically. +-C +-C Start of "CASE" statement implemented with COMPUTED GO TO. +- GO TO (60,60,100,120,140,160) CFLAG +-C +- 60 CONTINUE +-C +-C CFLAG = 1 or 2. Successful step. Have we reached an output point? +- 80 CONTINUE +- IF (TNOW.LT.TOUT) THEN +-C +-C Take another step. +- GO TO 40 +- ELSE +-C +-C Reached an output point. Call INTRP to obtain the answer at TOUT. +-C Specify 'Solution only' and all the components of the solution +-C (NWANT = NEQ). The values are output in YOUT(*). It is necessary +-C to provide storage only for the number of components requested and +-C here YPOUT is a dummy. In general more than one output point might +-C be obtained by interpolation after a single step by CT. That is the +-C reason for the jump to the statement labelled 80. For many problems +-C it is very important to take advantage of this possibility. +-C +- CALL INTRP(TOUT,'Solution only',NWANT,YOUT,YPOUT,F,WORK, +- & WRKINT,NINT) +- WRITE (OUTFIL,'(2E13.5)') YOUT(1), YOUT(2) +- IF (KOUNTR.LT.MAXPER) THEN +- KOUNTR = KOUNTR + 1 +- TOUT = TOUT + TWOPI +- GO TO 80 +- END IF +- GO TO 180 +- END IF +-C +- 100 CONTINUE +-C +-C CFLAG = 3. Although a considerable amount of work has been done, continue. +- GO TO 40 +-C +- 120 CONTINUE +-C +-C CFLAG = 4. The problem appears to be stiff. +- WRITE (*,'(A/)') ' The problem appears to be stiff. ' +- STOP +-C +- 140 CONTINUE +-C +-C CFLAG = 5. The accuracy request is too stringent. +- WRITE (*,'(A/)') ' The accuracy request is too stringent. ' +- STOP +-C +- 160 CONTINUE +-C +-C CFLAG = 6. The global error estimation scheme broke down. This +-C cannot occur because we did not ask for global error estimation. +-C +- WRITE (*,'(A/)') ' Global error estimation broke down. ' +- STOP +-C +- 180 CONTINUE +-C End of "CASE" statement implemented with COMPUTED GO TO. +-C +- CLOSE (OUTFIL) +-C +-C The subroutine STAT is used to obtain some information about the progress +-C of the integration. TOTF is the total number of calls to F made so far +-C in the integration; it is a machine-independent measure of work. At present +-C the integration is finished, so the value printed out refers to the overall +-C cost of the integration. STPCST is the cost in calls to F of a typical +-C step with this method. WASTE is the fraction of steps after the first that +-C were rejected. A "large" value of WASTE is usually the result of a mistake +-C in the coding of F. It can also be the result of a solution component that +-C is not smooth -- singular or with many places where a low order derivative +-C is not continuous. STPSOK is the number of accepted steps. +-C +- CALL STAT(TOTF,STPCST,WASTE,STPSOK,HNEXT) +- WRITE (*,'(/A,1PE10.2,0P/A,I10/A,I10/A,F10.2/A,I10)') +- &' The integration reached ', TNOW, +- &' The cost of the integration in calls to F was', TOTF, +- &' The number of calls to F per step is ', STPCST, +- &' The fraction of failed steps was ', WASTE, +- &' The number of accepted steps was ', STPSOK +-C +- STOP +- END +- SUBROUTINE F(T,Y,YP) +-C .. Scalar Arguments .. +- DOUBLE PRECISION T +-C .. Array Arguments .. +- DOUBLE PRECISION Y(*), YP(*) +-C .. Parameters .. +- DOUBLE PRECISION K +- PARAMETER (K=0.1) +-C .. Scalars in Common .. +- DOUBLE PRECISION B +-C .. Intrinsic Functions .. +- INTRINSIC COS +-C .. Common blocks .. +- COMMON /BPARAM/B +-C .. Executable Statements .. +- YP(1) = Y(2) +- YP(2) = -K*Y(2) - Y(1)**3 + B*COS(T) +- RETURN +- END +//GO.SYSIN DD tmpl3a.f +echo tmpl3b.f 1>&2 +sed >tmpl3b.f <<'//GO.SYSIN DD tmpl3b.f' 's/^-//' +-C +-C Template 3b +-C +-C This template comes in two variants, 3a and 3b, in files tmpl3a.for and +-C tmpl3b.for, respectively. They illustrate different aspects of the RK +-C suite on the same problem. The task could be handled more simply with +-C UT; the purpose of the template is to illustrate how to use CT when more +-C control over the integration is required. Specifically, variant 3b +-C illustrates how to use CT with METHOD = 3 to advance the integration a +-C step at a time and how to get answers at specific points. It also +-C illustrates how to assess the global error with GLBERR. +-C +-C Problem: Integrate a forced Duffing equation that models an electric +-C circuit with a nonlinear inductor. The behavior of solutions +-C depends on the value of a parameter B that governs the size of +-C the forcing term. This problem is discussed at length in F.C. +-C Moon, Chaotic Vibrations, John Wiley & Sons, Inc., New York, +-C 1987; numerical results are reported on p. 272. Written as +-C a first order system, the second order equation is +-C +-C y1' = y2, +-C y2' = - 0.1 y2 - y1**3 + B cos(t). +-C +-C A Poincare map is used to study the qualitative behavior of the +-C solutions. This means that solution values are to be computed +-C at t = 2*pi*k for k = 1,2,...,n and y2(t) plotted against y1(t). +-C +-C Exploration of the qualitative behavior of solutions could lead +-C to integration of the differential equation for a great many +-C initial values. Here the single set of initial values +-C y1(0) = 3.3, y2(0) = -3.3 +-C is considered. It is planned that the integration extend for +-C many multiples of the period 2*pi of the forcing function. +-C The template takes n = 100. To have some accuracy at the end +-C of a "long" integration, it is necessary to specify a moderately +-C stringent tolerance. In this variant TOL is taken to be 1.0D-7. +-C The general scaling of the initial values and the anticipated +-C behavior of the solution components suggest that threshold +-C values of 1.0D-10 on each component might be reasonable. +-C +-C The tolerance has been reduced substantially from the value +-C used in Variant 3a. At this tolerance METHOD = 3 is preferred. +-C Although output is desired at specific points, they do not +-C occur frequently enough to impact the integration -- the +-C tolerance is stringent enough that there are a number of steps +-C between output points. One purpose of this template is to show +-C how to obtain output at specific points with METHOD = 3. +-C +-C Another purpose of this template is to illustrate global error +-C assessment. GLBERR can be called after any call to CT to assess +-C the global error. If the global error gets too large to be +-C meaningful or if the code has evidence that the scheme for +-C assessing the global error might be unreliable, the integration +-C is terminated by CT. In the template the global error is reported +-C at the end of the run or whenever the assessment breaks down. +-C +-C The character of the problem depends on the value of B. According +-C to Moon, the solution is periodic when B = 9.8 and becomes +-C chaotic when B is about 10.0. The behavior of the global error +-C is very different in these circumstances. By definition the +-C solution is very sensitive to changes in the initial conditions +-C when there is chaos. This means that it is very difficult to +-C compute accurately a specific solution curve -- the global error +-C must get large rather quickly. Variant 3b takes B = 11.0 so that +-C chaos is present, and the global error assessment will eventually +-C break down. Also included in tmpl3.out is the output when +-C B = 9.8, a periodic solution. +-C +-C With the codes of RKSUITE, precisely the same results are +-C obtained whether or not global error assessment is requested. +-C When METHOD = 2 or 3, a run costs approximately three times as +-C many calls to the routine defining the differential equations +-C when ERRASS is .TRUE. as when it is .FALSE., and when METHOD = 1, +-C it costs approximately four times as many. For this reason the +-C facility is normally used only for spot checks. A run with +-C B = 9.8 is relatively expensive; you might want to reduce the +-C the run time by reducing MAXPER. +-C +-C With both variants of the template the integrations are +-C sufficiently expensive that if MESAGE is set .TRUE., there are +-C a number of returns reporting that 5000 function evaluations +-C have been made since the last message. To suppress these +-C messages, MESAGE is set .FALSE. Another purpose of this +-C template is to illustrate the processing of error messages and +-C the decisions that are made at each step of an integration. +-C +-C NOTES: As may be seen in tmpl3.out, with a specific computer, precision, +-C compiler, ... , the global error assessment breaks down at about +-C t = 121 after 34348 function evaluations have been made. The +-C maximum weighted error seen at any step prior to this point is +-C about 0.07! A more realistic assessment of the accuracy is +-C provided by the individual RMS weighted errors. At this point +-C the larger is about 0.003. Obviously it is difficult to follow +-C a solution in the presence of chaos even with a stringent +-C tolerance. If the global error assessment is turned off, the +-C integration will proceed to completion at t = 200*pi. It costs +-C 65414 function evaluations. It is important to understand what +-C all this means. The integration is successful because the code +-C controls the local error at each step -- what it is supposed to +-C do. However, when the problem itself is not stable, control of +-C local error does not imply control of the global error that +-C really interests us. The global error assessment brings to our +-C attention that we are not getting what we want. The situation +-C is different when B = 9.8 and the solution is periodic. As the +-C results for this case in tmpl3.out show, this solution has an +-C acceptable accuracy for the whole interval of integration. +-C +-C For the typical problem that is moderately stable the global +-C error is comparable to the local tolerance, and users come to +-C expect this. It is unfortunate that the global error assessment +-C facility is too expensive for routine use because there is no +-C doubt that many solutions of initial value problem are not nearly +-C as accurate as the users of the software think they are. +-C +-C Working storage must be provided in the array WORK(*) of +-C length LENWRK. Although storage is no problem with only +-C NEQ = 2 equations, LENWRK is taken here to be 21*NEQ, +-C the least that can be used in CT with METHOD = 3 when global +-C error assessment is done (ERRASS = .TRUE.). +-C +-C .. Parameters .. +- INTEGER NEQ, METHOD, LENWRK, OUTFIL, MAXPER +- PARAMETER (NEQ=2,METHOD=3,LENWRK=21*NEQ,OUTFIL=9, +- & MAXPER=100) +- DOUBLE PRECISION ZERO, ONE, FOUR +- PARAMETER (ZERO=0.0D0,ONE=1.0D0,FOUR=4.0D0) +-C .. Local Scalars .. +- DOUBLE PRECISION ERRMAX, HNEXT, HSTART, PI, TEND, TERRMX, +- & TNOW, TOL, TSTART, TWOPI, WASTE +- INTEGER CFLAG, KOUNTR, L, STPCST, STPSOK, TOTF +- LOGICAL ERRASS, MESAGE +-C .. Local Arrays .. +- DOUBLE PRECISION RMSERR(NEQ), THRES(NEQ), WORK(LENWRK), +- & YNOW(NEQ), YPNOW(NEQ), YSTART(NEQ) +-C .. External Subroutines .. +- EXTERNAL CT, ENVIRN, F, GLBERR, RESET, SETUP, STAT +-C .. Scalars in Common .. +- DOUBLE PRECISION B +-C .. Intrinsic Functions .. +- INTRINSIC ATAN +-C .. Common blocks .. +- COMMON /BPARAM/B +-C .. Executable Statements .. +-C +- PI = FOUR*ATAN(ONE) +- TWOPI = PI + PI +-C +-C Set the parameter defining the character of the solutions. +-C +- B = 11.0D0 +-C +-C Initialize output. +-C +- WRITE (*,'(A,I3,A,F5.1/)') +- &' Template 3b with METHOD = ',METHOD,' and B = ', B +-C +-C Set the initial conditions. TEND is set to the first output point +-C because with METHOD = 3, output is obtained by integrating to TEND +-C and then resetting TEND to obtain the next output point. +-C +- TSTART = ZERO +- YSTART(1) = 3.3D0 +- YSTART(2) = -3.3D0 +- TEND = TSTART + TWOPI +-C +-C Because the solution components may be computed at many points, they are +-C written to a file on unit OUTFIL. Subsequently, the results can be studied, +-C plotted, or manipulated as necessary. Naming of files is system-dependent, +-C so the name here, PLOT.DAT, may need to be changed. Begin by writing the +-C initial values to PLOT.DAT in a form suitable for plotting y2 against y1. +-C +- OPEN (UNIT=OUTFIL,FILE='PLOT.DAT') +-C +- WRITE (OUTFIL,'(2E13.5)') YSTART(1), YSTART(2) +-C +-C Set error control parameters. +-C +- TOL = 1.0D-7 +- DO 20 L = 1, NEQ +- THRES(L) = 1.0D-10 +- 20 CONTINUE +-C +-C Call the setup routine. Set MESAGE = .FALSE. because this will be a +-C a relatively expensive integration and it is annoying to be told +-C repeatedly that 5000 function evaluations have been required. The +-C global error is assessed. Automatic selection of an initial step +-C size is specified by setting HSTART to zero. +-C +- MESAGE = .FALSE. +- ERRASS = .TRUE. +- HSTART = ZERO +- CALL SETUP(NEQ,TSTART,YSTART,TEND,TOL,THRES,METHOD,'Complex Task', +- & ERRASS,HSTART,WORK,LENWRK,MESAGE) +-C +-C KOUNTR counts the number of output points. +-C +- KOUNTR = 1 +- 40 CONTINUE +- CALL CT(F,TNOW,YNOW,YPNOW,WORK,CFLAG) +-C +-C The code is not permitted to go past TEND, the end of the interval of +-C integration, so it will shorten the step when necessary so as to produce +-C an answer at TEND exactly. To obtain answers at specific points with +-C METHOD = 3, which has no interpolation capability, this fact is exploited +-C by stepping to TEND, and then resetting TEND to the next outpoint point +-C with the subroutine RESET. KOUNTR counts the number of output points. +-C +-C Loop until an output point is reached, or the code gets into trouble. +-C Interrogate CFLAG to decide on an appropriate course of action. +-C Because MESAGE = .FALSE., it is necessary to write out an explanation +-C of any trouble except for a catastrophe when an explanation is provided +-C automatically. +-C +-C Start of "CASE" statement implemented with COMPUTED GO TO. +- GO TO (60,60,80,100,120,140) CFLAG +-C +- 60 CONTINUE +-C +-C CFLAG = 1 or 2. Successful step. Have we reached an output point? +- IF (TNOW.LT.TEND) THEN +-C +-C Take another step. +- GO TO 40 +- ELSE +-C +-C Reached an output point. Save the solution and reset the end point to +-C continue on. After MAXPER output points, jump to where the global error +-C assessment is obtained. +-C +- WRITE (OUTFIL,'(2E13.5)') YNOW(1), YNOW(2) +- IF (KOUNTR.LT.MAXPER) THEN +- KOUNTR = KOUNTR + 1 +- TEND = TEND + TWOPI +- CALL RESET(TEND) +- GO TO 40 +- ELSE +- GO TO 160 +- END IF +- END IF +-C +- 80 CONTINUE +-C +-C CFLAG = 3. Although a considerable amount of work has been done, continue. +- GO TO 40 +-C +- 100 CONTINUE +-C +-C CFLAG = 4. The problem appears to be stiff. +- WRITE (*,'(A/)') +- &' The problem appears to be stiff. ' +- STOP +-C +- 120 CONTINUE +-C +-C CFLAG = 5. The accuracy request is too stringent. +- WRITE (*,'(A/)') +- &' The accuracy request is too stringent. ' +- STOP +-C +- 140 CONTINUE +-C +-C CFLAG = 6. The global error estimation scheme broke down. Report this +-C fact and then jump to where the assessment is obtained. +-C +- WRITE (*,'(A/)') +- &' Global error estimation broke down. ' +- GO TO 160 +-C +- 160 CONTINUE +-C End of "CASE" statement implemented with computed GO TO. +-C +- CLOSE (OUTFIL) +-C +-C Obtain the global error assessment by a call to GLBERR and report it. To +-C facilitate experimentation with the cost of global error assessment, test +-C whether ERRASS was set .TRUE. so that a call to GLBERR makes sense. +-C +- IF (ERRASS) THEN +- CALL GLBERR(RMSERR,ERRMAX,TERRMX,WORK) +- WRITE (*,'(/A,1PE9.2)') +- &' The tolerance was ',TOL +- WRITE (*,'(A,1PE9.2,A,1PE9.2,A)') +- &' The worst global error observed was ',ERRMAX, +- &'. (It occurred at ',TERRMX,'.)' +- WRITE (*,'(A)') +- &' The RMS errors in the individual components were:' +- DO 180 L = 1,NEQ +- WRITE (*,'(50X,1PE9.2)') RMSERR(L) +- 180 CONTINUE +- END IF +-C +-C The subroutine STAT is used to obtain some information about the progress +-C of the integration. TOTF is the total number of calls to F made so far +-C in the integration; it is a machine-independent measure of work. At present +-C the integration is finished, so the value printed out refers to the overall +-C cost of the integration. STPCST is the cost in calls to F of a typical +-C step with this method. WASTE is the fraction of steps after the first that +-C were rejected. A "large" value of WASTE is usually the result of a mistake +-C in the coding of F. It can also be the result of a solution component that +-C is not smooth -- singular or with many places where a low order derivative +-C is not continuous. STPSOK is the number of accepted steps. +-C +- CALL STAT(TOTF,STPCST,WASTE,STPSOK,HNEXT) +- WRITE (*,'(/A,1PE10.2,0P/A,I10/A,I10/A,F10.2/A,I10)') +- &' The integration reached ', TNOW, +- &' The cost of the integration in calls to F was', TOTF, +- &' The number of calls to F per step is ', STPCST, +- &' The fraction of failed steps was ', WASTE, +- &' The number of accepted steps was ', STPSOK +-C +- STOP +- END +- SUBROUTINE F(T,Y,YP) +-C .. Scalar Arguments .. +- DOUBLE PRECISION T +-C .. Array Arguments .. +- DOUBLE PRECISION Y(*), YP(*) +-C .. Parameters .. +- DOUBLE PRECISION K +- PARAMETER (K=0.1) +-C .. Scalars in Common .. +- DOUBLE PRECISION B +-C .. Intrinsic Functions .. +- INTRINSIC COS +-C .. Common blocks .. +- COMMON /BPARAM/B +-C .. Executable Statements .. +- YP(1) = Y(2) +- YP(2) = -K*Y(2) - Y(1)**3 + B*COS(T) +- RETURN +- END +//GO.SYSIN DD tmpl3b.f