diff --git a/CHANGELOG.md b/CHANGELOG.md index aa4f5c9be5..35564649ff 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -20,6 +20,8 @@ it in future. ### Removed +* Remove Millepede + ## 24.11 Release after first round of breaking changes. Requires CVMFS release ≥ 24.10. diff --git a/millepede/CMakeLists.txt b/millepede/CMakeLists.txt deleted file mode 100644 index e2bd46ea1e..0000000000 --- a/millepede/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -# Create a library called "libmillepede" which includes the source files given in -# the array . -# The extension is already found. Any number of sources could be listed here. - -# Set the build type. Possibilities are None, Debug, Release, -# RelWithDebInfo and MinSizeRel -SET(CMAKE_BUILD_TYPE Release) - -Set(SRCS Mille.cc) -Set(HEADERS Mille.h) -Set(LIBRARY_NAME millepede) - -GENERATE_LIBRARY() \ No newline at end of file diff --git a/millepede/COPYING.LIB b/millepede/COPYING.LIB deleted file mode 100644 index 5bc8fb2c8f..0000000000 --- a/millepede/COPYING.LIB +++ /dev/null @@ -1,481 +0,0 @@ - GNU LIBRARY GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1991 Free Software Foundation, Inc. - 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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 - - 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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/millepede/Dbandmatrix.f90 b/millepede/Dbandmatrix.f90 deleted file mode 100644 index 3d3829f40a..0000000000 --- a/millepede/Dbandmatrix.f90 +++ /dev/null @@ -1,947 +0,0 @@ - -! Code converted using TO_F90 by Alan Miller -! Date: 2012-04-18 Time: 19:56:08 - -!> \file -!! Symmetric (band) matrix routines. -!! -!! \author Volker Blobel, University Hamburg, 2005-2009 (initial Fortran77 version) -!! \author Claus Kleinwort, DESY (maintenance and developement) -!! -!! \copyright -!! Copyright (c) 2009 - 2015 Deutsches Elektronen-Synchroton, -!! Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n -!! 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. \n\n -!! 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. \n\n -!! You should have received a copy of the GNU Library General Public -!! License along with this program (see the file COPYING.LIB for more -!! details); if not, write to the Free Software Foundation, Inc., -!! 675 Mass Ave, Cambridge, MA 02139, USA. -!! -!! For the original broken lines implementation by V. Blobel -!! (University Hamburg). -!!\verbatim -!! ************************************************************* -!! * * -!! * Subroutines for symmetric and symmetric band matrices, * -!! * based on the (square root free) Cholesky decomposition. * -!! * * -!! ************************************************************* -!! -!! All floating point arguments are in DOUBLE PRECISION (and all -!! entry names start with a D). -!! -!! The Cholesky decomposition transforms a symmetric matrix W -!! e.g. the matrix from normal equation of least squares, -!! according to -!! W = L D L^ (L^ means L transposed) -!! where D is a diagonal matrix and L is a unit triangular matrix -!! (diagonal elements all ones, all elements above diagonal zero). -!! -!! The above decomposition allows to solve a matrix equation -!! W x = b -!! in two steps, using an auxiliary vector y: -!! -!! solve L y = b for y, and -!! -!! solve D L^ x = y for x. -!! -!! The inverse matrix of W can be calculated from the decomposition. -!! -!! In least-squares normal equations the inverse matrix is equal to -!! the covariance matrix of the fitted parameters. All diagonal elements -!! of the inverse matrix, the parameter variances, are positive, and -!! the matrix is positive-definite (all eigenvalues > 0). -!! -!! The Cholesky algorithm is stable for a positive-definite matrix. -!! The standard form of the Cholesky algorithm includes n square roots -!! for a n-by-n matrix, and is possible only for positive-definite -!! matrices. The version used here is squareroot-free; this algorithm -!! does not necessarily break down in the indefinite case, although -!! it is potentially unstable in this case. All decomposition routines -!! include a check for singularity, and this check needs an auxiliary -!! array AUX of dimension n. -!! -!! Method: The Cholesky algorithm for symmetric matrix decomposition -!! makes use of the symmetry. The operation count (leading term) -!! is n**3/6 (compared to n**3/3 for normal Gaussian elimination). -!! The solution of the two triangular systems involves operations -!! proportional to n**2. -!! -!! The real advantage of the Cholesky algorithm is for band matrices, -!! where all matrix elements outside of a band with total width -!! (2m+1) around the diagonal are zero. The band structure is kept -!! in the decomposition, and allows a fast solution of matrix equations. -!! The operation count (leading term) is proportional to m**2*n -!! and thus (for fixed m) linear in n. Thus for n=100 and m=2 the -!! Cholesky algorithm for the band matrix is 1000 times faster than -!! the standard solution method. -!! -!! The inverse of a band matrix is a full matrix. It is not necessary -!! to calculate the inverse, if only the solution for a matrix equation -!! is needed. However the inverse is often needed, because the elements -!! of the inverse are the variances and covariances of parameters in -!! a least-squares fit. The inverse can be calculated afterwards from -!! the decomposition. Since the inverse matrix is a full matrix, this -!! has of course an operation count proportional to n**3. -!! -!! Usually only the elements of the inverse in and around the diagonal -!! are really needed, and this subset of inverse elements, corresponding -!! to the original band, can be calculated from the decomposition with -!! an operation count, which is linear in n. Thus all variances (the -!! diagonal elements) and covariances between neighbour parameters -!! are calculated in a short time even for large matrices. -!! -!! Matrix storage: the mathematical indexing of matrix elements follows -!! the scheme: -!! -!! ( W11 W12 W13 ... W1n ) -!! ( W21 W22 W23 ... W2n ) -!! W = ( ... ... ... ... ) -!! ( ... ... ... ... ) -!! ( Wn1 Wn2 Wn3 ... Wnn ) -!! -!! and a storage in an array would require n**2 words, although the -!! symmetric matrix has only (n**2+n)/2 different elements, and a band -!! matrix has less than (m+1)*n different elements. Therefore the -!! following storage schemes are used. -!! -!! Symmetric matrix: the elements are in the order -!! W11 W12 W22 W13 W23 W33 W14 ... Wnn -!! with total (n**2+n)/2 array elements. -!! -!! Band matrix: a band matrix of bandwidth m is stored in an array -!! of dimension W(m+1,n), according to -!! -!! W(1,.) W(2,.) W(3,.) -!! -------------------------------- -!! W11 W12 W13 -!! W22 W23 W24 -!! W33 W34 W35 -!! ... -!! Wnn - - -!! -!! The example is for a bandwidth of m=2; three elements at the end -!! are unused. The diagonal elements are in the array elements W(1,.). -!! -!! This package includes subroutines for: -!! -!! (1) Symmetric matrix W: decomposition, solution, inverse -!! -!! (2) Symmetric band matrix: decomposition, solution, complete -!! inverse and band part of the inverse -!! -!! (3) Symmetric band matrix of band width m=1: decomposition, -!! solution, complete, inverse and band part of the inverse -!! -!! (4) Symmetric band matrix of band width m=2: decomposition, -!! solution, complete, inverse and band part of the inverse -!! -!! (5) Symmetric matrix with band structure, bordered by full row/col -!! (not yet included) -!! -!! The subroutines for a fixed band width of m=1 and of m=2 are -!! faster than the general routine, because certain loops are avoided -!! and replaced by the direct code. -!! -!! Historical remark: the square-root algorithm was invented by the -!! french Mathematician Andre-Louis Cholesky (1875 - 1918). -!! Cholesky's method of computing solutions to the normal equations was -!! published 1924, after the death of Cholesky, by Benoit. -!! The method received little attention after its publication in 1924. -!! In 1948 the method was analysed in a paper by Fox, Huskey and -!! Wilkinson, and in the same year Turing published a paper on the -!! stability of the method. -!! -!! The fast method to calculate the band part of the inverse matrix -!! is usually not mentioned in the literature. An exception is: -!! I.S.Duff, A.M.Erisman and J.K.Reid, Direct Methods for Sparse -!! Matrices, Oxford Science Publications, 1986. -!! The following original work is quoted in this book: -!! K.Takahashi, J.Fagan and M.Chin, Formation of a sparse bus -!! impedance matrix and its application to short circuit study. -!! Proceedings 8th PICA Conference, Minneapolis, Minnesota, 1973 -!! A.M.Erisman and W.F.Tinney, On computing certain elements of the -!! inverse of a sparse matrix, CACM 18, 177-179, 1975 -!! -!! -!! -!! symmetric decomposit. solution inv-element inverse -!! ---------------- |-----------|-----------|--------------|-----------| -!! n x n matrix DCHDEC DCHSLV - DCHINV -!! band matrix m,n DBCDEC DBCSLV DBCIEL/DBCINB DBCINV -!! bandwidth m=1 DB2DEC DB2SLV DB2IEL - -!! bandwidth m=2 DB3DEC DB3SLV DB3IEL - -!! -!! The DB2... and DB3... routines are special routines for a fixed bandwidth -!! of 1 and 2, they are faster versions of the general DBG... routines. -!! The complete inverse matrix can be obtained by DBGINV. -!! The routine DBGPRI can be used to print all types of band matrices. -!! -!! The decomposition in routines ...DEC replaces (overwrites) the -!! original matrix (the number of elements is identical). All other -!! routines require W to be the already decomposed matrix. -!! The matrix L is a unit lower triangular matrix, with ones on the -!! diagonal, which have not be stored. Instead the inverse of the -!! diagonal elements of matrix D are stored in those places. -!! -!! In the solution routines ...SLV the array B is the right-hand matrix, -!! the array is the resulting solution. The same array can be used -!! for B and X. -!! -!! -!! W(.) and V(.) are symmetric n-by-n matrices with (N*N+N)/2 elements -!! -!! SUBROUTINE DCHDEC(W,N, AUX) ! decomposition, symmetric matrix -!! ENTRY DCHSLV(W,N,B, X) ! solution B -> X -!! ENTRY DCHINV(W,N, V) ! inversion -!! -!! SUBROUTINE DCFDEC(W,N) ! modified composition, symmetric -!! ! alternative to DCHDEC -!! -!! W(.) and V(.) are band matrices, n rows, band width m (i.e. the total -!! width of the band is (2m+1). -!! With MP1 = m +1, the array has dimension W(MP1,N). -!! The symmetric matrix VS has (N*N+N)/2 elements -!! -!! SUBROUTINE DBCDEC(W,MP1,N, AUX) ! decomposition, bandwidth M -!! ENTRY DBCSLV(W,MP1,N,B, X) ! solution B -> X -!! ENTRY DBCIEL(W,MP1,N, V) ! V = inverse band matrix elements -!! ENTRY DBCINV(W,MP1,N, VS) ! V = inverse symmetric matrix -!! -!! SUBROUTINE DBFDEC(W,MP1,N) ! modified decomposition, bandwidth M -!! ! alternative to DBCDEC -!! -!! SUBROUTINE DBCPRB(W,MP1,N) ! print band matrix -!! SUBROUTINE DBCPRV(W,MP1,N,B) ! print corr band matrix and pars -!! -!! SUBROUTINE DB2DEC(W,N, AUX) ! decomposition (M=1) -!! ENTRY DB2SLV(W,N,B, X) ! solution B -> X -!! ENTRY DB2IEL(W,N, V) ! V = inverse band matrix elements -!! -!! SUBROUTINE DB3DEC(W,N, AUX) ! decomposition (M=2) -!! ENTRY DB3SLV(W,N,B, X) ! solution B -> X -!! ENTRY DB3IEL(W,N, V) ! V = inverse band matrix elements -!!\endverbatim - - -! (1) Symmetric matrix W: decomposition, solution, inverse - -!> Decomposition of symmetric matrix. -!! -!! ENTRY DCHSLV(W,N,B, X) for solution B -> X \n -!! ENTRY DCHINV(W,N,V) for inversion -!! -!! \param [in,out] W symmetirc matrix -!! \param [in] N size -!! \param [in] AUX scratch array - -SUBROUTINE dchdec(w,n, aux) - USE mpdef - - implicit none - INTEGER(mpi) :: i - INTEGER(mpi) :: ii - INTEGER(mpi) :: j - INTEGER(mpi) :: jj - INTEGER(mpi) :: k - INTEGER(mpi) :: kk - INTEGER(mpi) :: l - INTEGER(mpi) :: m - - - REAL(mpd), INTENT(IN OUT) :: w(*) - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(OUT) :: aux(n) - - REAL(mpd) :: b(*),x(*),v(*),suma,ratio - ! ... - DO i=1,n - aux(i)=16.0_mpd*w((i*i+i)/2) ! save diagonal elements - END DO - ii=0 - DO i=1,n - ii=ii+i - IF(w(ii)+aux(i) /= aux(i)) THEN ! GT - w(ii)=1.0_mpd/w(ii) ! (I,I) div ! - ELSE - w(ii)=0.0_mpd - END IF - jj=ii - DO j=i+1,n - ratio=w(i+jj)*w(ii) ! (I,J) (I,I) - kk=jj - DO k=j,n - w(kk+j)=w(kk+j)-w(kk+i)*ratio ! (K,J) (K,I) - kk=kk+k - END DO ! K - w(i+jj)=ratio ! (I,J) - jj=jj+j - END DO ! J - END DO ! I - - - RETURN - - ENTRY dchslv(w,n,b, x) ! solution B -> X - WRITE(*,*) 'before copy' - DO i=1,n - x(i)=b(i) - END DO - WRITE(*,*) 'after copy' - ii=0 - DO i=1,n - suma=x(i) - DO k=1,i-1 - suma=suma-w(k+ii)*x(k) ! (K,I) - END DO - x(i)=suma - ii=ii+i - END DO - WRITE(*,*) 'after forward' - DO i=n,1,-1 - suma=x(i)*w(ii) ! (I,I) - kk=ii - DO k=i+1,n - suma=suma-w(kk+i)*x(k) ! (K,I) - kk=kk+k - END DO - x(i)=suma - ii=ii-i - END DO - WRITE(*,*) 'after backward' - RETURN - - ENTRY dchinv(w,n,v) ! inversion - ii=(n*n-n)/2 - DO i=n,1,-1 - suma=w(ii+i) ! (I,I) - DO j=i,1,-1 - DO k=j+1,n - l=MIN(i,k) - m=MAX(i,k) - suma=suma-w(j+(k*k-k)/2)*v(l+(m*m-m)/2) ! (J,K) (I,K) - END DO - v(ii+j)=suma ! (I,J) - suma=0.0_mpd - END DO - ii=ii-i+1 - END DO -END SUBROUTINE dchdec - -!> Etimate condition. -!! -!! \param [in] W symmetric matrix -!! \param [in] N size -!! \param [in] AUX scratch array -!! \return condition - -REAL(mps) FUNCTION condes(w,n,aux) - USE mpdef - - implicit none - REAL(mps) :: cond - INTEGER(mpi) :: i - INTEGER(mpi) :: ir - INTEGER(mpi) :: is - INTEGER(mpi) :: k - INTEGER(mpi) :: kk - REAL(mps) :: xla1 - REAL(mps) :: xlan - - - REAL(mpd), INTENT(IN) :: w(*) - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN OUT) :: aux(n) - - REAL(mpd) :: suma,sumu,sums - - ir=1 - is=1 - DO i=1,n - IF(w((i*i+i)/2) < w((is*is+is)/2)) is=i ! largest Dii - IF(w((i*i+i)/2) > w((ir*ir+ir)/2)) ir=i ! smallest Dii - END DO - - sumu=0.0 ! find smallest eigenvalue - sums=0.0 - DO i=n,1,-1 ! backward - suma=0.0 - IF(i == ir) suma=1.0_mpd - kk=(i*i+i)/2 - DO k=i+1,n - suma=suma-w(kk+i)*aux(k) ! (K,I) - kk=kk+k - END DO - aux(i)=suma - sumu=sumu+aux(i)*aux(i) - END DO - xlan=REAL(w((ir*ir+ir)/2)*SQRT(sumu),mps) - IF(xlan /= 0.0) xlan=1.0/xlan - - DO i=1,n - IF(i == is) THEN - sums=1.0_mpd - ELSE IF(i > is) THEN - sums=sums+w(is+(i*i-i)/2)**2 - END IF - END DO ! is Ws - xla1=0.0 - IF(w((is*is+is)/2) /= 0.0) xla1=REAL(SQRT(sums)/w((is*is+is)/2),mps) - - cond=0.0 - IF(xla1 > 0.0.AND.xlan > 0.0) cond=xla1/xlan - ! estimated condition - condes=cond -END FUNCTION condes - - -! (2) Symmetric band matrix: decomposition, solution, complete -! inverse and band part of the inverse -!> Decomposition of symmetric band matrix. -!! -!! ENTRY DBCSLV(W,MP1,N,B, X) for solution B -> X \n -!! ENTRY DBCIEL(W,MP1,N, V), V = inverse band matrix elements \n -!! ENTRY DBCINB(W,MP1,N, VS), VS = band part of inverse symmetric matrix \n -!! ENTRY DBCINV(W,MP1,N, VS), V = inverse symmetric matrix -!! -!! \param [in,out] W symmetric band matrix -!! \param [in] MP1 band width (M) + 1 -!! \param [in] N size -!! \param [in] AUX scratch array - -SUBROUTINE dbcdec(w,mp1,n, aux) ! decomposition, bandwidth M - USE mpdef - - implicit none - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: k - ! M=MP1-1 N*M(M-1) dot operations - - REAL(mpd), INTENT(IN OUT) :: w(mp1,n) - INTEGER(mpi), INTENT(IN) :: mp1 - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(OUT) :: aux(n) - ! decompos - REAL(mpd) :: v(mp1,n),b(n),x(n), vs(*),rxw - ! ... - DO i=1,n - aux(i)=16.0_mpd*w(1,i) ! save diagonal elements - END DO - DO i=1,n - IF(w(1,i)+aux(i) /= aux(i)) THEN - w(1,i)=1.0/w(1,i) - ELSE - w(1,i)=0.0_mpd ! singular - END IF - DO j=1,MIN(mp1-1,n-i) - rxw=w(j+1,i)*w(1,i) - DO k=1,MIN(mp1-1,n-i)+1-j - w(k,i+j)=w(k,i+j)-w(k+j,i)*rxw - END DO - w(j+1,i)=rxw - END DO - END DO - RETURN - - ENTRY dbcslv(w,mp1,n,b, x) ! solution B -> X - ! N*(2M-1) dot operations - DO i=1,n - x(i)=b(i) - END DO - DO i=1,n ! forward substitution - DO j=1,MIN(mp1-1,n-i) - x(j+i)=x(j+i)-w(j+1,i)*x(i) - END DO - END DO - DO i=n,1,-1 ! backward substitution - rxw=x(i)*w(1,i) - DO j=1,MIN(mp1-1,n-i) - rxw=rxw-w(j+1,i)*x(j+i) - END DO - x(i)=rxw - END DO - RETURN - - ENTRY dbciel(w,mp1,n, v) ! V = inverse band matrix elements - ! N*M*(M-1) dot operations - DO i=n,1,-1 - rxw=w(1,i) - DO j=i,MAX(1,i-mp1+1),-1 - DO k=j+1,MIN(n,j+mp1-1) - rxw=rxw-v(1+ABS(i-k),MIN(i,k))*w(1+k-j,j) - END DO - v(1+i-j,j)=rxw - rxw=0.0 - END DO - END DO - RETURN - - ENTRY dbcinb(w,mp1,n, vs) ! VS = band part of inverse symmetric matrix - ! N*M*(M-1) dot operations - DO i=n,1,-1 - rxw=w(1,i) - DO j=i,MAX(1,i-mp1+1),-1 - DO k=j+1,MIN(n,j+mp1-1) - rxw=rxw-vs((MAX(i,k)*(MAX(i,k)-1))/2+MIN(i,k))*w(1+k-j,j) - END DO - vs((i*i-i)/2+j)=rxw - rxw=0.0 - END DO - ! DO J=MAX(1,I-MP1+1)-1,1,-1 - ! VS((I*I-I)/2+J)=0.0 - ! END DO - END DO - RETURN - - ENTRY dbcinv(w,mp1,n, vs) ! V = inverse symmetric matrix - ! N*N/2*(M-1) dot operations - DO i=n,1,-1 - rxw=w(1,i) - DO j=i,1,-1 - DO k=j+1,MIN(n,j+mp1-1) - rxw=rxw-vs((MAX(i,k)*(MAX(i,k)-1))/2+MIN(i,k))*w(1+k-j,j) - END DO - vs((i*i-i)/2+j)=rxw - rxw=0.0 - END DO - END DO - RETURN -END SUBROUTINE dbcdec - -!> Print corr band matrix and pars. -!! -!! \param [in] W symmetric band matrix -!! \param [in] MP1 band width (M) + 1 -!! \param [in] N size -!! \param [in] B vector - -SUBROUTINE dbcprv(w,mp1,n,b) - USE mpdef - - implicit none - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: nj - REAL(mps) :: rho - - - REAL(mpd), INTENT(IN OUT) :: w(mp1,n) - INTEGER(mpi), INTENT(IN) :: mp1 - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(OUT) :: b(n) - - REAL(mpd) :: ERR - INTEGER(mpi) :: irho(5) - ! ... - WRITE(*,*) ' ' - WRITE(*,101) - - DO i=1,n - ERR=SQRT(w(1,i)) - nj=0 - DO j=2,mp1 - IF(i+1-j > 0.AND.nj < 5) THEN - nj=nj+1 - rho=REAL(w(j,i+1-j)/(ERR*SQRT(w(1,i+1-j))),mps) - irho(nj)=NINT(100.0*ABS(rho),mpi) - IF(rho < 0.0) irho(nj)=-irho(nj) - END IF - END DO - WRITE(*,102) i,b(i),ERR,(irho(j),j=1,nj) - END DO - WRITE(*,103) -101 FORMAT(5X,'i Param',7X,'error',7X,' c(i,i-1) c(i,i-2)'/) -102 FORMAT(1X,i5,2G12.4,1X,5I9) -103 FORMAT(33X,'(correlation coefficients in percent)') -END SUBROUTINE dbcprv - -!> Print band matrix. -!! -!! \param [in] W symmetric band matrix -!! \param [in] MP1 band width (M) + 1 -!! \param [in] N size - -SUBROUTINE dbcprb(w,mp1,n) - USE mpdef - - implicit none - INTEGER(mpi) :: i - INTEGER(mpi) :: j - - - REAL(mpd), INTENT(IN OUT) :: w(mp1,n) - INTEGER(mpi), INTENT(IN) :: mp1 - INTEGER(mpi), INTENT(IN) :: n - - - ! ... - IF(mp1 > 6) RETURN - WRITE(*,*) ' ' - WRITE(*,101) - DO i=1,n - WRITE(*,102) i,(w(j,i),j=1,mp1) - END DO - WRITE(*,*) ' ' -101 FORMAT(5X,'i Diag ') -102 FORMAT(1X,i5,6G12.4) -END SUBROUTINE dbcprb - - -! (3) Symmetric band matrix of band width m=1: decomposition, -! solution, complete, inverse and band part of the inverse - -!> Decomposition (M=1). -!! -!! W is a symmetrix positive definite band matrix of bandwidth 1(+1). -!! W(1,.) are the diagonal elements, W(2,.) is the next -!! diagonals; W(2,N) is never referenced. -!! AUX is an auxiliary array of length N. -!! W is decomposed to L D Lt, where D = diagonal and L unit triangular. -!! A row is set to zero, if the diagonal element is reduced in previous -!! steps by a word length (i.e. global correlation coefficient large). -!! The resulting L and D replace W: the diagonal elements W(1,...) will -!! contain the inverse of the D-elements; the diagonal elements of L are -!! all 1 and not stored. The other elements of L are stored in the -!! corresponding elements of W. -!! -!! ENTRY DB2SLV(W,N,B, X), solution B -> X \n -!! ENTRY DB2IEL(W,N, V), V = inverse band matrix elements -!! -!! \param [in,out] W symmetric band matrix -!! \param [in] N size -!! \param [in] AUX scratch array - -SUBROUTINE db2dec(w,n, aux) - USE mpdef - - implicit none - INTEGER(mpi) :: i - - - REAL(mpd), INTENT(IN OUT) :: w(2,n) - INTEGER(mpi), INTENT(IN OUT) :: n - REAL(mpd), INTENT(OUT) :: aux(n) - - REAL(mpd) :: v(2,n),b(n),x(n), rxw - - DO i=1,n - aux(i)=16.0_mpd*w(1,i) ! save diagonal elements - END DO - DO i=1,n-1 - IF(w(1,i)+aux(i) /= aux(i)) THEN - w(1,i)=1.0_mpd/w(1,i) - rxw=w(2,i)*w(1,i) - w(1,i+1)=w(1,i+1)-w(2,i)*rxw - w(2,i)=rxw - ELSE ! singular - w(1,i)=0.0_mpd - w(2,i)=0.0_mpd - END IF - END DO - IF(w(1,n)+aux(n) > aux(n)) THEN ! N - w(1,n)=1.0_mpd/w(1,n) - ELSE ! singular - w(1,n)=0.0_mpd - END IF - RETURN - - ENTRY db2slv(w,n,b, x) ! solution B -> X - ! The equation W(original)*X=B is solved for X; input is B in vector X. - DO i=1,n - x(i)=b(i) - END DO - DO i=1,n-1 ! by forward substitution - x(i+1)=x(i+1)-w(2,i)*x(i) - END DO - x(n)=x(n)*w(1,n) ! and backward substitution - DO i=n-1,1,-1 - x(i)=x(i)*w(1,i)-w(2,i)*x(i+1) - END DO - RETURN - - ENTRY db2iel(w,n, v) ! V = inverse band matrix elements - ! The band elements of the inverse of W(original) are calculated, - ! and stored in V in the same order as in W. - ! Remaining elements of the inverse are not calculated. - v(1,n )= w(1,n) - v(2,n-1)=-v(1,n )*w(2,n-1) - DO i=n-1,3,-1 - v(1,i )= w(1,i )-v(2,i )*w(2,i ) - v(2,i-1)=-v(1,i )*w(2,i-1) - END DO - v(1,2)= w(1,2)-v(2,2)*w(2,2) - v(2,1)=-v(1,2)*w(2,1) - v(1,1)= w(1,1)-v(2,1)*w(2,1) -END SUBROUTINE db2dec - - -! (4) Symmetric band matrix of band width m=2: decomposition, -! solution, complete, inverse and band part of the inverse - -!> Decomposition (M=2). -!! -!! W is a symmetrix positive definite band matrix of bandwidth 2(+1). -!! W(1,.) are the diagonal elements, W(2,.) and W(3,.) are the next -!! diagonals; W(3,N-1), W(2,N) and W(3,N) are never referenced. -!! AUX is an auxiliary array of length N. -!! W is decomposed to L D Lt, where D = diagonal and L unit triangular. -!! A row is set to zero, if the diagonal element is reduced in previous -!! steps by a word length (i.e. global correlation coefficient large). -!! The resulting L and D replace W: the diagonal elements W(1,...) will -!! contain the inverse of the D-elements; the diagonal elements of L are -!! all 1 and not stored. The other elements of L are stored in the -!! corresponding elements of W. -!! -!! ENTRY DB3SLV(W,N,B, X), solution B -> X \n -!! ENTRY DB3IEL(W,N, V), V = inverse band matrix elements -!! -!! \param [in,out] W symmetric band matrix -!! \param [in] N size -!! \param [in] AUX scratch array - -SUBROUTINE db3dec(w,n, aux) ! decomposition (M=2) - USE mpdef - - implicit none - INTEGER(mpi) :: i - - - REAL(mpd), INTENT(IN OUT) :: w(3,n) - INTEGER(mpi), INTENT(IN OUT) :: n - REAL(mpd), INTENT(OUT) :: aux(n) - ! decompos - - REAL(mpd) :: v(3,n),b(n),x(n), rxw - - DO i=1,n - aux(i)=16.0_mpd*w(1,i) ! save diagonal elements - END DO - DO i=1,n-2 - IF(w(1,i)+aux(i) /= aux(i)) THEN - w(1,i)=1.0_mpd/w(1,i) - rxw=w(2,i)*w(1,i) - w(1,i+1)=w(1,i+1)-w(2,i)*rxw - w(2,i+1)=w(2,i+1)-w(3,i)*rxw - w(2,i)=rxw - rxw=w(3,i)*w(1,i) - w(1,i+2)=w(1,i+2)-w(3,i)*rxw - w(3,i)=rxw - ELSE ! singular - w(1,i)=0.0_mpd - w(2,i)=0.0_mpd - w(3,i)=0.0_mpd - END IF - END DO - IF(w(1,n-1)+aux(n-1) > aux(n-1)) THEN - w(1,n-1)=1.0_mpd/w(1,n-1) - rxw=w(2,n-1)*w(1,n-1) - w(1,n)=w(1,n)-w(2,n-1)*rxw - w(2,n-1)=rxw - ELSE ! singular - w(1,n-1)=0.0_mpd - w(2,n-1)=0.0_mpd - END IF - IF(w(1,n)+aux(n) > aux(n)) THEN - w(1,n)=1.0_mpd/w(1,n) - ELSE ! singular - w(1,n)=0.0_mpd - END IF - RETURN - - ENTRY db3slv(w,n,b, x) ! solution B -> X - DO i=1,n - x(i)=b(i) - END DO - DO i=1,n-2 ! by forward substitution - x(i+1)=x(i+1)-w(2,i)*x(i) - x(i+2)=x(i+2)-w(3,i)*x(i) - END DO - x(n)=x(n)-w(2,n-1)*x(n-1) - x(n)=x(n)*w(1,n) ! and backward substitution - x(n-1)=x(n-1)*w(1,n-1)-w(2,n-1)*x(n) - DO i=n-2,1,-1 - x(i)=x(i)*w(1,i)-w(2,i)*x(i+1)-w(3,i)*x(i+2) - END DO - RETURN - - ENTRY db3iel(w,n, v) ! V = inverse band matrix elements - ! The band elements of the inverse of W(original) are calculated, - ! and stored in V in the same order as in W. - ! Remaining elements of the inverse are not calculated. - v(1,n )= w(1,n) - v(2,n-1)=-v(1,n )*w(2,n-1) - v(3,n-2)=-v(2,n-1)*w(2,n-2)-v(1,n )*w(3,n-2) - v(1,n-1)= w(1,n-1) -v(2,n-1)*w(2,n-1) - v(2,n-2)=-v(1,n-1)*w(2,n-2)-v(2,n-1)*w(3,n-2) - v(3,n-3)=-v(2,n-2)*w(2,n-3)-v(1,n-1)*w(3,n-3) - DO i=n-2,3,-1 - v(1,i )= w(1,i ) -v(2,i )*w(2,i )-v(3,i)*w(3,i ) - v(2,i-1)=-v(1,i )*w(2,i-1)-v(2,i)*w(3,i-1) - v(3,i-2)=-v(2,i-1)*w(2,i-2)-v(1,i)*w(3,i-2) - END DO - v(1,2)= w(1,2) -v(2,2)*w(2,2)-v(3,2)*w(3,2) - v(2,1)=-v(1,2)*w(2,1)-v(2,2)*w(3,1) - v(1,1)= w(1,1) -v(2,1)*w(2,1)-v(3,1)*w(3,1) -END SUBROUTINE db3dec - - -! (5) Symmetric matrix with band structure, bordered by full row/col -! - is not yet included - - -! SUBROUTINE BSOLV1(N,CU,RU,CK,RK,CH, BK,UH, AU) ! 1 -! Input: CU = 3*N array replaced by decomposition -! RU N array rhs -! CK diagonal element -! RK rhs -! CH N-vector - -! Aux: AU N-vector auxliliary array - -! Result: FK curvature -! BK variance -! UH smoothed data points - - -! DOUBLE PRECISION CU(3,N),CI(3,N),CK,BK,AU(N),UH(N) -! ... -! CALL BDADEC(CU,3,N, AU) ! decomposition -! CALL DBASLV(CU,3,N, RU,UH) ! solve for zero curvature -! CALL DBASLV(CU,3,N, CH,AU) ! solve for aux. vector -! CTZ=0.0D0 -! ZRU=0.0D0 -! DO I=1,N -! CTZ=CTZ+CH(I)*AU(I) ! cT z -! ZRU=ZRU+RY(I)*AU(I) ! zT ru -! END DO -! BK=1.0D0/(CK-CTZ) ! variance of curvature -! FK=BK *(RK-ZRU) ! curvature -! DO I=1,N -! UH(I)=UH(I)-FK*AU(I) ! smoothed data points -! END DO -! RETURN - -! ENTRY BINV1(N,CU,CI, FK,AU) -! DOUBLE PRECISION CI(3,N) -! ... -! CALL DBAIBM(CU,3,N, CI) ! block part of inverse -! DO I=1,N -! CI(1,I)=CI(1,I)+FK*AU(I)*AU(I) ! diagonal elements -! IF(I.LT.N) CI(2,I)=CI(2,I)+FK*AU(I)*AU(I+1) ! next diagonal -! IF(I.LT.N-1) CI(3,I)=CI(3,I)+FK*AU(I)*AU(I+2) ! next diagonal -! END DO - -! END - -!> Decomposition of symmetric matrix. -!! -!! Modified Cholesky decomposition, -!! Philip E.Gill, Walter Murray and Margarete H.Wright: -!! Practical Optimization, Academic Press, 1981 -!! -!! \param [in,out] W symmetirc matrix -!! \param [in] N size - -SUBROUTINE dcfdec(w,n) - USE mpdef - - IMPLICIT NONE - REAL(mpd), INTENT(OUT) :: w(*) - INTEGER(mpi), INTENT(IN) :: n - INTEGER(mpi) :: i,j,k - REAL(mpd) :: epsm,gamm,xchi,beta,delta,theta - - epsm=EPSILON(epsm) ! machine precision - gamm=0.0_mpd ! max diagonal element - xchi=0.0_mpd ! max off-diagonal element - DO k=1,n - gamm=MAX(gamm,ABS(w((k*k+k)/2))) - DO j=k+1,n - xchi=MAX(xchi,ABS(w((j*j-j)/2+k))) - END DO - END DO - beta=SQRT(MAX(gamm,xchi/MAX(1.0_mpd,SQRT(REAL(n*n-1,mpd))),epsm)) - delta=epsm*MAX(1.0_mpd,gamm+xchi) - - DO k=1,n - DO i=1,k-1 - w((k*k-k)/2+i)=w((k*k-k)/2+i)*w((i*i+i)/2) - END DO - DO j=k+1,n - DO i=1,k-1 - w((j*j-j)/2+k)=w((j*j-j)/2+k)-w((k*k-k)/2+i)*w((j*j-j)/2+i) - END DO - END DO - theta=0.0_mpd - DO j=k+1,n - theta=MAX(theta,ABS(w((j*j-j)/2+k))) - END DO - w((k*k+k)/2)=1.0_mpd/MAX(ABS(w((k*k+k)/2)),(theta/beta)**2,delta) - DO j=k+1,n - w((j*j+j)/2)=w((j*j+j)/2)-w((j*j-j)/2+k)**2*w((k*k+k)/2) - END DO - END DO ! K - -END SUBROUTINE dcfdec - -!> Decomposition of symmetric band matrix. -!! -!! Band matrix modified Cholesky decomposition, -!! Philip E.Gill, Walter Murray and Margarete H.Wright: -!! Practical Optimization, Academic Press, 1981 -!! -!! \param [in,out] W symmetric band matrix -!! \param [in] MP1 band width (M) + 1 -!! \param [in] N size - -SUBROUTINE dbfdec(w,mp1,n) - USE mpdef - - IMPLICIT NONE - REAL(mpd), INTENT(OUT) :: w(mp1,n) - INTEGER(mpi), INTENT(IN OUT) :: mp1 - INTEGER(mpi), INTENT(IN) :: n - INTEGER(mpi) :: i,j,k - REAL(mpd) :: epsm,gamm,xchi,beta,delta,theta - - epsm=EPSILON(epsm) ! machine precision - gamm=0.0_mpd ! max diagonal element - xchi=0.0_mpd ! max off-diagonal element - DO k=1,n - gamm=MAX(gamm,ABS(w(1,k))) - DO j=2,MIN(mp1,n-k+1) - xchi=MAX(xchi,ABS(w(j,k))) - END DO - END DO - beta=SQRT(MAX(gamm,xchi/MAX(1.0_mpd,SQRT(REAL(n*n-1,mpd))),epsm)) - delta=epsm*MAX(1.0_mpd,gamm+xchi) - - DO k=1,n - DO i=2,MIN(mp1,k) - w(i,k-i+1)=w(i,k-i+1)*w(1,k-i+1) - END DO - DO j=2,MIN(mp1,n-k+1) - DO i=MAX(2,j+k+1-mp1),k - w(j,k)=w(j,k)-w(k-i+2,i-1)*w(j-i+k+1,i-1) - END DO - END DO - theta=0.0_mpd - DO j=2,MIN(mp1,n-k+1) - theta=MAX(theta,ABS(w(j,k))) - END DO - w(1,k)=1.0_mpd/MAX(ABS(w(1,k)),(theta/beta)**2,delta) - DO j=2,MIN(mp1,n-k+1) - w(1,k+j-1)=w(1,k+j-1)-w(1,k)*w(j,k)**2 - END DO - END DO ! K - -END SUBROUTINE dbfdec - - diff --git a/millepede/Mille.cc b/millepede/Mille.cc deleted file mode 100644 index bb0f0105c4..0000000000 --- a/millepede/Mille.cc +++ /dev/null @@ -1,228 +0,0 @@ - -/** \file - * Create Millepede-II C-binary record. - * - * \author Gero Flucke, University Hamburg, 2006 - * - * \copyright - * Copyright (c) 2009 - 2015 Deutsches Elektronen-Synchroton, - * Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n - * 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. \n\n - * 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. \n\n - * You should have received a copy of the GNU Library General Public - * License along with this program (see the file COPYING.LIB for more - * details); if not, write to the Free Software Foundation, Inc., - * 675 Mass Ave, Cambridge, MA 02139, USA. - */ - -/** - * author : Gero Flucke, University Hamburg, 2006 - * date : October 2006 - * $Revision: 1.3 $ - * $Date: 2007/04/16 17:47:38 $ - * (last update by $Author: flucke $) - */ - -#include "Mille.h" - -#include -#include - -//___________________________________________________________________________ - -/// Opens outFileName (by default as binary file). -/** - * \param[in] outFileName file name - * \param[in] asBinary flag for binary - * \param[in] writeZero flag for keeping of zeros - */ -Mille::Mille(const char *outFileName, bool asBinary, bool writeZero) : - myOutFile(outFileName, (asBinary ? (std::ios::binary | std::ios::out) : std::ios::out)), - myAsBinary(asBinary), myWriteZero(writeZero), myBufferPos(-1), myHasSpecial(false) -{ - // Instead myBufferPos(-1), myHasSpecial(false) and the following two lines - // we could call newSet() and kill()... - myBufferInt[0] = 0; - myBufferFloat[0] = 0.; - - if (!myOutFile.is_open()) { - std::cerr << "Mille::Mille: Could not open " << outFileName - << " as output file." << std::endl; - } -} - -//___________________________________________________________________________ -/// Closes file. -Mille::~Mille() -{ - myOutFile.close(); -} - -//___________________________________________________________________________ -/// Add measurement to buffer. -/** - * \param[in] NLC number of local derivatives - * \param[in] derLc local derivatives - * \param[in] NGL number of global derivatives - * \param[in] derGl global derivatives - * \param[in] label global labels - * \param[in] rMeas measurement (residuum) - * \param[in] sigma error - */ -void Mille::mille(int NLC, const float *derLc, - int NGL, const float *derGl, const int *label, - float rMeas, float sigma) -{ - if (sigma <= 0.) return; - if (myBufferPos == -1) this->newSet(); // start, e.g. new track - if (!this->checkBufferSize(NLC, NGL)) return; - - // first store measurement - ++myBufferPos; - myBufferFloat[myBufferPos] = rMeas; - myBufferInt [myBufferPos] = 0; - - // store local derivatives and local 'lables' 1,...,NLC - for (int i = 0; i < NLC; ++i) { - if (derLc[i] || myWriteZero) { // by default store only non-zero derivatives - ++myBufferPos; - myBufferFloat[myBufferPos] = derLc[i]; // local derivatives - myBufferInt [myBufferPos] = i+1; // index of local parameter - } - } - - // store uncertainty of measurement in between locals and globals - ++myBufferPos; - myBufferFloat[myBufferPos] = sigma; - myBufferInt [myBufferPos] = 0; - - // store global derivatives and their labels - for (int i = 0; i < NGL; ++i) { - if (derGl[i] || myWriteZero) { // by default store only non-zero derivatives - if ((label[i] > 0 || myWriteZero) && label[i] <= myMaxLabel) { // and for valid labels - ++myBufferPos; - myBufferFloat[myBufferPos] = derGl[i]; // global derivatives - myBufferInt [myBufferPos] = label[i]; // index of global parameter - } else { - std::cerr << "Mille::mille: Invalid label " << label[i] - << " <= 0 or > " << myMaxLabel << std::endl; - } - } - } -} - -//___________________________________________________________________________ -/// Add special data to buffer. -/** - * \param[in] nSpecial number of floats/ints - * \param[in] floatings floats - * \param[in] integers ints - */ -void Mille::special(int nSpecial, const float *floatings, const int *integers) -{ - if (nSpecial == 0) return; - if (myBufferPos == -1) this->newSet(); // start, e.g. new track - if (myHasSpecial) { - std::cerr << "Mille::special: Special values already stored for this record." - << std::endl; - return; - } - if (!this->checkBufferSize(nSpecial, 0)) return; - myHasSpecial = true; // after newSet() (Note: MILLSP sets to buffer position...) - - // myBufferFloat[.] | myBufferInt[.] - // ------------------------------------ - // 0.0 | 0 - // -float(nSpecial) | 0 - // The above indicates special data, following are nSpecial floating and nSpecial integer data. - - ++myBufferPos; // zero pair - myBufferFloat[myBufferPos] = 0.; - myBufferInt [myBufferPos] = 0; - - ++myBufferPos; // nSpecial and zero - myBufferFloat[myBufferPos] = -nSpecial; // automatic conversion to float - myBufferInt [myBufferPos] = 0; - - for (int i = 0; i < nSpecial; ++i) { - ++myBufferPos; - myBufferFloat[myBufferPos] = floatings[i]; - myBufferInt [myBufferPos] = integers[i]; - } -} - -//___________________________________________________________________________ -/// Reset buffers, i.e. kill derivatives accumulated for current set. -void Mille::kill() -{ - myBufferPos = -1; -} - -//___________________________________________________________________________ -/// Write buffer (set of derivatives with same local parameters) to file. -void Mille::end() -{ - if (myBufferPos > 0) { // only if anything stored... - const int numWordsToWrite = (myBufferPos + 1)*2; - - if (myAsBinary) { - myOutFile.write(reinterpret_cast(&numWordsToWrite), - sizeof(numWordsToWrite)); - myOutFile.write(reinterpret_cast(myBufferFloat), - (myBufferPos+1) * sizeof(myBufferFloat[0])); - myOutFile.write(reinterpret_cast(myBufferInt), - (myBufferPos+1) * sizeof(myBufferInt[0])); - } else { - myOutFile << numWordsToWrite << "\n"; - for (int i = 0; i < myBufferPos+1; ++i) { - myOutFile << myBufferFloat[i] << " "; - } - myOutFile << "\n"; - - for (int i = 0; i < myBufferPos+1; ++i) { - myOutFile << myBufferInt[i] << " "; - } - myOutFile << "\n"; - } - } - myBufferPos = -1; // reset buffer for next set of derivatives -} - -//___________________________________________________________________________ -/// Initialize for new set of locals, e.g. new track. -void Mille::newSet() -{ - myBufferPos = 0; - myHasSpecial = false; - myBufferFloat[0] = 0.0; - myBufferInt [0] = 0; // position 0 used as error counter -} - -//___________________________________________________________________________ -/// Enough space for next nLocal + nGlobal derivatives incl. measurement? -/** - * \param[in] nLocal number of local derivatives - * \param[in] nGlobal number of global derivatives - * \return true if sufficient space available (else false) - */ -bool Mille::checkBufferSize(int nLocal, int nGlobal) -{ - if (myBufferPos + nLocal + nGlobal + 2 >= myBufferSize) { - ++(myBufferInt[0]); // increase error count - std::cerr << "Mille::checkBufferSize: Buffer too short (" - << myBufferSize << ")," - << "\n need space for nLocal (" << nLocal<< ")" - << "/nGlobal (" << nGlobal << ") local/global derivatives, " - << myBufferPos + 1 << " already stored!" - << std::endl; - return false; - } else { - return true; - } -} diff --git a/millepede/Mille.h b/millepede/Mille.h deleted file mode 100644 index 24bdf5bff7..0000000000 --- a/millepede/Mille.h +++ /dev/null @@ -1,78 +0,0 @@ -#ifndef MILLE_H -#define MILLE_H - -/** \file - * Define class Mille. - * - * \author Gero Flucke, University Hamburg, 2006 - * - * \copyright - * Copyright (c) 2009 - 2015 Deutsches Elektronen-Synchroton, - * Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n - * 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. \n\n - * 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. \n\n - * You should have received a copy of the GNU Library General Public - * License along with this program (see the file COPYING.LIB for more - * details); if not, write to the Free Software Foundation, Inc., - * 675 Mass Ave, Cambridge, MA 02139, USA. - */ - -#include - -/** - * \class Mille - * - * Class to write a C binary (cf. below) file of a given name and to fill it - * with information used as input to **pede**. - * Use its member functions \c mille(), \c special(), \c kill() and \c end() - * as you would use the fortran \ref mille.f90 "MILLE" - * and its entry points \c MILLSP, \c KILLE and \c ENDLE. - * - * For debugging purposes constructor flags enable switching to text output and/or - * to write also derivatives and labels which are ==0. - * But note that **pede** will not be able to read text output and has not been tested with - * derivatives/labels ==0. - * - * author : Gero Flucke - * date : October 2006 - * $Revision: 1.3 $ - * $Date: 2007/04/16 17:47:38 $ - * (last update by $Author: flucke $) - */ - -/// Class to write C binary file. -class Mille -{ - public: - Mille(const char *outFileName, bool asBinary = true, bool writeZero = false); - ~Mille(); - - void mille(int NLC, const float *derLc, int NGL, const float *derGl, - const int *label, float rMeas, float sigma); - void special(int nSpecial, const float *floatings, const int *integers); - void kill(); - void end(); - - private: - void newSet(); - bool checkBufferSize(int nLocal, int nGlobal); - - std::ofstream myOutFile; ///< C-binary for output - bool myAsBinary; ///< if false output as text - bool myWriteZero; ///< if true also write out derivatives/labels ==0 - /// buffer size for ints and floats - enum {myBufferSize = 5000}; ///< buffer size for ints and floats - int myBufferInt[myBufferSize]; ///< to collect labels etc. - float myBufferFloat[myBufferSize]; ///< to collect derivatives etc. - int myBufferPos; ///< position in buffer - bool myHasSpecial; ///< if true, special(..) already called for this record - /// largest label allowed: 2^31 - 1 - enum {myMaxLabel = (0xFFFFFFFF - (1 << 31))}; -}; -#endif diff --git a/millepede/WIKI b/millepede/WIKI deleted file mode 100644 index 05be0424db..0000000000 --- a/millepede/WIKI +++ /dev/null @@ -1 +0,0 @@ -Documentation is maintained at www.wiki.terascale.de/index.php/Millepede_II . diff --git a/millepede/cfortran.h b/millepede/cfortran.h deleted file mode 100644 index ed23011d84..0000000000 --- a/millepede/cfortran.h +++ /dev/null @@ -1,2363 +0,0 @@ -/* cfortran.h 4.3 */ -/* http://www-zeus.desy.de/~burow/cfortran/ */ -/* Burkhard Burow burow@desy.de 1990 - 2001. */ - -#ifndef __CFORTRAN_LOADED -#define __CFORTRAN_LOADED - -/* - THIS FILE IS PROPERTY OF BURKHARD BUROW. IF YOU ARE USING THIS FILE YOU - SHOULD ALSO HAVE ACCESS TO CFORTRAN.DOC WHICH PROVIDES TERMS FOR USING, - MODIFYING, COPYING AND DISTRIBUTING THE CFORTRAN.H PACKAGE. -*/ - -/* - Avoid symbols already used by compilers and system *.h: - __ - OSF1 zukal06 V3.0 347 alpha, cc -c -std1 cfortest.c - - */ - - -/* First prepare for the C compiler. */ - -#ifndef ANSI_C_preprocessor /* i.e. user can override. */ -#ifdef __CF__KnR -#define ANSI_C_preprocessor 0 -#else -#ifdef __STDC__ -#define ANSI_C_preprocessor 1 -#else -#define _cfleft 1 -#define _cfright -#define _cfleft_cfright 0 -#define ANSI_C_preprocessor _cfleft/**/_cfright -#endif -#endif -#endif - -#if ANSI_C_preprocessor -#define _0(A,B) A##B -#define _(A,B) _0(A,B) /* see cat,xcat of K&R ANSI C p. 231 */ -#define _2(A,B) A##B /* K&R ANSI C p.230: .. identifier is not replaced */ -#define _3(A,B,C) _(A,_(B,C)) -#else /* if it turns up again during rescanning. */ -#define _(A,B) A/**/B -#define _2(A,B) A/**/B -#define _3(A,B,C) A/**/B/**/C -#endif - -#if (defined(vax)&&defined(unix)) || (defined(__vax__)&&defined(__unix__)) -#define VAXUltrix -#endif - -#include /* NULL [in all machines stdio.h] */ -#include /* strlen, memset, memcpy, memchr. */ -#if !( defined(VAXUltrix) || defined(sun) || (defined(apollo)&&!defined(__STDCPP__)) ) -#include /* malloc,free */ -#else -#include /* Had to be removed for DomainOS h105 10.4 sys5.3 425t*/ -#ifdef apollo -#define __CF__APOLLO67 /* __STDCPP__ is in Apollo 6.8 (i.e. ANSI) and onwards */ -#endif -#endif - -#if !defined(__GNUC__) && !defined(__sun) && (defined(sun)||defined(VAXUltrix)||defined(lynx)) -#define __CF__KnR /* Sun, LynxOS and VAX Ultrix cc only supports K&R. */ - /* Manually define __CF__KnR for HP if desired/required.*/ -#endif /* i.e. We will generate Kernighan and Ritchie C. */ -/* Note that you may define __CF__KnR before #include cfortran.h, in order to -generate K&R C instead of the default ANSI C. The differences are mainly in the -function prototypes and declarations. All machines, except the Apollo, work -with either style. The Apollo's argument promotion rules require ANSI or use of -the obsolete std_$call which we have not implemented here. Hence on the Apollo, -only C calling FORTRAN subroutines will work using K&R style.*/ - - -/* Remainder of cfortran.h depends on the Fortran compiler. */ - -#if defined(CLIPPERFortran) || defined(pgiFortran) -#define f2cFortran -#endif - -/* VAX/VMS does not let us \-split long #if lines. */ -/* Split #if into 2 because some HP-UX can't handle long #if */ -#if !(defined(NAGf90Fortran)||defined(f2cFortran)||defined(hpuxFortran)||defined(apolloFortran)||defined(sunFortran)||defined(IBMR2Fortran)||defined(CRAYFortran)) -#if !(defined(mipsFortran)||defined(DECFortran)||defined(vmsFortran)||defined(CONVEXFortran)||defined(PowerStationFortran)||defined(AbsoftUNIXFortran)||defined(AbsoftProFortran)||defined(SXFortran)) -/* If no Fortran compiler is given, we choose one for the machines we know. */ -#if defined(lynx) || defined(VAXUltrix) -#define f2cFortran /* Lynx: Only support f2c at the moment. - VAXUltrix: f77 behaves like f2c. - Support f2c or f77 with gcc, vcc with f2c. - f77 with vcc works, missing link magic for f77 I/O.*/ -#endif -#if defined(__hpux) /* 921107: Use __hpux instead of __hp9000s300 */ -#define hpuxFortran /* Should also allow hp9000s7/800 use.*/ -#endif -#if defined(apollo) -#define apolloFortran /* __CF__APOLLO67 also defines some behavior. */ -#endif -#if defined(sun) || defined(__sun) -#define sunFortran -#endif -#if defined(_IBMR2) -#define IBMR2Fortran -#endif -#if defined(_CRAY) -#define CRAYFortran /* _CRAYT3E also defines some behavior. */ -#endif -#if defined(_SX) -#define SXFortran -#endif -#if defined(mips) || defined(__mips) -#define mipsFortran -#endif -#if defined(vms) || defined(__vms) -#define vmsFortran -#endif -#if defined(__alpha) && defined(__unix__) -#define DECFortran -#endif -#if defined(__convex__) -#define CONVEXFortran -#endif -#if defined(VISUAL_CPLUSPLUS) -#define PowerStationFortran -#endif -#endif /* ...Fortran */ -#endif /* ...Fortran */ - -/* Split #if into 2 because some HP-UX can't handle long #if */ -#if !(defined(NAGf90Fortran)||defined(f2cFortran)||defined(hpuxFortran)||defined(apolloFortran)||defined(sunFortran)||defined(IBMR2Fortran)||defined(CRAYFortran)) -#if !(defined(mipsFortran)||defined(DECFortran)||defined(vmsFortran)||defined(CONVEXFortran)||defined(PowerStationFortran)||defined(AbsoftUNIXFortran)||defined(AbsoftProFortran)||defined(SXFortran)) -/* If your compiler barfs on ' #error', replace # with the trigraph for # */ - #error "cfortran.h: Can't find your environment among:\ - - MIPS cc and f77 2.0. (e.g. Silicon Graphics, DECstations, ...) \ - - IBM AIX XL C and FORTRAN Compiler/6000 Version 01.01.0000.0000 \ - - VAX VMS CC 3.1 and FORTRAN 5.4. \ - - Alpha VMS DEC C 1.3 and DEC FORTRAN 6.0. \ - - Alpha OSF DEC C and DEC Fortran for OSF/1 AXP Version 1.2 \ - - Apollo DomainOS 10.2 (sys5.3) with f77 10.7 and cc 6.7. \ - - CRAY \ - - NEC SX-4 SUPER-UX \ - - CONVEX \ - - Sun \ - - PowerStation Fortran with Visual C++ \ - - HP9000s300/s700/s800 Latest test with: HP-UX A.08.07 A 9000/730 \ - - LynxOS: cc or gcc with f2c. \ - - VAXUltrix: vcc,cc or gcc with f2c. gcc or cc with f77. \ - - f77 with vcc works; but missing link magic for f77 I/O. \ - - NO fort. None of gcc, cc or vcc generate required names.\ - - f2c : Use #define f2cFortran, or cc -Df2cFortran \ - - NAG f90: Use #define NAGf90Fortran, or cc -DNAGf90Fortran \ - - Absoft UNIX F77: Use #define AbsoftUNIXFortran or cc -DAbsoftUNIXFortran \ - - Absoft Pro Fortran: Use #define AbsoftProFortran \ - - Portland Group Fortran: Use #define pgiFortran" -/* Compiler must throw us out at this point! */ -#endif -#endif - - -#if defined(VAXC) && !defined(__VAXC) -#define OLD_VAXC -#pragma nostandard /* Prevent %CC-I-PARAMNOTUSED. */ -#endif - -/* Throughout cfortran.h we use: UN = Uppercase Name. LN = Lowercase Name. */ - -#if defined(f2cFortran) || defined(NAGf90Fortran) || defined(DECFortran) || defined(mipsFortran) || defined(apolloFortran) || defined(sunFortran) || defined(CONVEXFortran) || defined(SXFortran) || defined(extname) -#define CFC_(UN,LN) _(LN,_) /* Lowercase FORTRAN symbols. */ -#define orig_fcallsc(UN,LN) CFC_(UN,LN) -#else -#if defined(CRAYFortran) || defined(PowerStationFortran) || defined(AbsoftProFortran) -#ifdef _CRAY /* (UN), not UN, circumvents CRAY preprocessor bug. */ -#define CFC_(UN,LN) (UN) /* Uppercase FORTRAN symbols. */ -#else /* At least VISUAL_CPLUSPLUS barfs on (UN), so need UN. */ -#define CFC_(UN,LN) UN /* Uppercase FORTRAN symbols. */ -#endif -#define orig_fcallsc(UN,LN) CFC_(UN,LN) /* CRAY insists on arg.'s here. */ -#else /* For following machines one may wish to change the fcallsc default. */ -#define CF_SAME_NAMESPACE -#ifdef vmsFortran -#define CFC_(UN,LN) LN /* Either case FORTRAN symbols. */ - /* BUT we usually use UN for C macro to FORTRAN routines, so use LN here,*/ - /* because VAX/VMS doesn't do recursive macros. */ -#define orig_fcallsc(UN,LN) UN -#else /* HP-UX without +ppu or IBMR2 without -qextname. NOT reccomended. */ -#define CFC_(UN,LN) LN /* Lowercase FORTRAN symbols. */ -#define orig_fcallsc(UN,LN) CFC_(UN,LN) -#endif /* vmsFortran */ -#endif /* CRAYFortran PowerStationFortran */ -#endif /* ....Fortran */ - -#define fcallsc(UN,LN) orig_fcallsc(UN,LN) -#define preface_fcallsc(P,p,UN,LN) CFC_(_(P,UN),_(p,LN)) -#define append_fcallsc(P,p,UN,LN) CFC_(_(UN,P),_(LN,p)) - -#define C_FUNCTION(UN,LN) fcallsc(UN,LN) -#define FORTRAN_FUNCTION(UN,LN) CFC_(UN,LN) - -#ifndef COMMON_BLOCK -#ifndef CONVEXFortran -#ifndef CLIPPERFortran -#if !(defined(AbsoftUNIXFortran)||defined(AbsoftProFortran)) -#define COMMON_BLOCK(UN,LN) CFC_(UN,LN) -#else -#define COMMON_BLOCK(UN,LN) _(_C,LN) -#endif /* AbsoftUNIXFortran or AbsoftProFortran */ -#else -#define COMMON_BLOCK(UN,LN) _(LN,__) -#endif /* CLIPPERFortran */ -#else -#define COMMON_BLOCK(UN,LN) _3(_,LN,_) -#endif /* CONVEXFortran */ -#endif /* COMMON_BLOCK */ - -#ifndef DOUBLE_PRECISION -#if defined(CRAYFortran) && !defined(_CRAYT3E) -#define DOUBLE_PRECISION long double -#else -#define DOUBLE_PRECISION double -#endif -#endif - -#ifndef FORTRAN_REAL -#if defined(CRAYFortran) && defined(_CRAYT3E) -#define FORTRAN_REAL double -#else -#define FORTRAN_REAL float -#endif -#endif - -#ifdef CRAYFortran -#ifdef _CRAY -#include -#else -#include "fortran.h" /* i.e. if crosscompiling assume user has file. */ -#endif -#define FLOATVVVVVVV_cfPP (FORTRAN_REAL *) /* Used for C calls FORTRAN. */ -/* CRAY's double==float but CRAY says pointers to doubles and floats are diff.*/ -#define VOIDP (void *) /* When FORTRAN calls C, we don't know if C routine - arg.'s have been declared float *, or double *. */ -#else -#define FLOATVVVVVVV_cfPP -#define VOIDP -#endif - -#ifdef vmsFortran -#if defined(vms) || defined(__vms) -#include -#else -#include "descrip.h" /* i.e. if crosscompiling assume user has file. */ -#endif -#endif - -#ifdef sunFortran -#if defined(sun) || defined(__sun) -#include /* Sun's FLOATFUNCTIONTYPE, ASSIGNFLOAT, RETURNFLOAT. */ -#else -#include "math.h" /* i.e. if crosscompiling assume user has file. */ -#endif -/* At least starting with the default C compiler SC3.0.1 of SunOS 5.3, - * FLOATFUNCTIONTYPE, ASSIGNFLOAT, RETURNFLOAT are not required and not in - * , since sun C no longer promotes C float return values to doubles. - * Therefore, only use them if defined. - * Even if gcc is being used, assume that it exhibits the Sun C compiler - * behavior in order to be able to use *.o from the Sun C compiler. - * i.e. If FLOATFUNCTIONTYPE, etc. are in math.h, they required by gcc. - */ -#endif - -#ifndef apolloFortran -#define COMMON_BLOCK_DEF(DEFINITION, NAME) extern DEFINITION NAME -#define CF_NULL_PROTO -#else /* HP doesn't understand #elif. */ -/* Without ANSI prototyping, Apollo promotes float functions to double. */ -/* Note that VAX/VMS, IBM, Mips choke on 'type function(...);' prototypes. */ -#define CF_NULL_PROTO ... -#ifndef __CF__APOLLO67 -#define COMMON_BLOCK_DEF(DEFINITION, NAME) \ - DEFINITION NAME __attribute((__section(NAME))) -#else -#define COMMON_BLOCK_DEF(DEFINITION, NAME) \ - DEFINITION NAME #attribute[section(NAME)] -#endif -#endif - -#ifdef __cplusplus -#undef CF_NULL_PROTO -#define CF_NULL_PROTO ... -#endif - - -#ifndef USE_NEW_DELETE -#ifdef __cplusplus -#define USE_NEW_DELETE 1 -#else -#define USE_NEW_DELETE 0 -#endif -#endif -#if USE_NEW_DELETE -#define _cf_malloc(N) new char[N] -#define _cf_free(P) delete[] P -#else -#define _cf_malloc(N) (char *)malloc(N) -#define _cf_free(P) free(P) -#endif - -#ifdef mipsFortran -#define CF_DECLARE_GETARG int f77argc; char **f77argv -#define CF_SET_GETARG(ARGC,ARGV) f77argc = ARGC; f77argv = ARGV -#else -#define CF_DECLARE_GETARG -#define CF_SET_GETARG(ARGC,ARGV) -#endif - -#ifdef OLD_VAXC /* Allow %CC-I-PARAMNOTUSED. */ -#pragma standard -#endif - -#define AcfCOMMA , -#define AcfCOLON ; - -/*-------------------------------------------------------------------------*/ - -/* UTILITIES USED WITHIN CFORTRAN.H */ - -#define _cfMIN(A,B) (As) { /* Need this to handle NULL string.*/ - while (e>s && *--e==t); /* Don't follow t's past beginning. */ - e[*e==t?0:1] = '\0'; /* Handle s[0]=t correctly. */ -} return s; } - -/* kill_trailingn(s,t,e) will kill the trailing t's in string s. e normally -points to the terminating '\0' of s, but may actually point to anywhere in s. -s's new '\0' will be placed at e or earlier in order to remove any trailing t's. -If es) { /* Watch out for neg. length string.*/ - while (e>s && *--e==t); /* Don't follow t's past beginning. */ - e[*e==t?0:1] = '\0'; /* Handle s[0]=t correctly. */ -} return s; } - -/* Note the following assumes that any element which has t's to be chopped off, -does indeed fill the entire element. */ -#ifndef __CF__KnR -static char *vkill_trailing(char* cstr, int elem_len, int sizeofcstr, char t) -#else -static char *vkill_trailing( cstr, elem_len, sizeofcstr, t) - char* cstr; int elem_len; int sizeofcstr; char t; -#endif -{ int i; -for (i=0; i= 4.3 gives message: - zow35> cc -c -DDECFortran cfortest.c - cfe: Fatal: Out of memory: cfortest.c - zow35> - Old __hpux had the problem, but new 'HP-UX A.09.03 A 9000/735' is fine - if using -Aa, otherwise we have a problem. - */ -#ifndef MAX_PREPRO_ARGS -#if !defined(__GNUC__) && (defined(VAXUltrix) || defined(__CF__APOLLO67) || (defined(sun)&&!defined(__sun)) || defined(_CRAY) || defined(__ultrix__) || (defined(__hpux)&&defined(__CF__KnR))) -#define MAX_PREPRO_ARGS 31 -#else -#define MAX_PREPRO_ARGS 99 -#endif -#endif - -#if defined(AbsoftUNIXFortran) || defined(AbsoftProFortran) -/* In addition to explicit Absoft stuff, only Absoft requires: - - DEFAULT coming from _cfSTR. - DEFAULT could have been called e.g. INT, but keep it for clarity. - - M term in CFARGT14 and CFARGT14FS. - */ -#define ABSOFT_cf1(T0) _(T0,_cfSTR)(0,ABSOFT1,0,0,0,0,0) -#define ABSOFT_cf2(T0) _(T0,_cfSTR)(0,ABSOFT2,0,0,0,0,0) -#define ABSOFT_cf3(T0) _(T0,_cfSTR)(0,ABSOFT3,0,0,0,0,0) -#define DEFAULT_cfABSOFT1 -#define LOGICAL_cfABSOFT1 -#define STRING_cfABSOFT1 ,MAX_LEN_FORTRAN_FUNCTION_STRING -#define DEFAULT_cfABSOFT2 -#define LOGICAL_cfABSOFT2 -#define STRING_cfABSOFT2 ,unsigned D0 -#define DEFAULT_cfABSOFT3 -#define LOGICAL_cfABSOFT3 -#define STRING_cfABSOFT3 ,D0 -#else -#define ABSOFT_cf1(T0) -#define ABSOFT_cf2(T0) -#define ABSOFT_cf3(T0) -#endif - -/* _Z introduced to cicumvent IBM and HP silly preprocessor warning. - e.g. "Macro CFARGT14 invoked with a null argument." - */ -#define _Z - -#define CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - S(T1,1) S(T2,2) S(T3,3) S(T4,4) S(T5,5) S(T6,6) S(T7,7) \ - S(T8,8) S(T9,9) S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14) -#define CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - S(T1,1) S(T2,2) S(T3,3) S(T4,4) S(T5,5) S(T6,6) S(T7,7) \ - S(T8,8) S(T9,9) S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14) \ - S(TF,15) S(TG,16) S(TH,17) S(TI,18) S(TJ,19) S(TK,20) S(TL,21) \ - S(TM,22) S(TN,23) S(TO,24) S(TP,25) S(TQ,26) S(TR,27) - -#define CFARGT14FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \ - F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \ - M CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) -#define CFARGT27FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \ - F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \ - F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) F(TL,21,1) \ - F(TM,22,1) F(TN,23,1) F(TO,24,1) F(TP,25,1) F(TQ,26,1) F(TR,27,1) \ - M CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) - -#if !(defined(PowerStationFortran)||defined(hpuxFortran800)) -/* Old CFARGT14 -> CFARGT14FS as seen below, for Absoft cross-compile yields: - SunOS> cc -c -Xa -DAbsoftUNIXFortran c.c - "c.c", line 406: warning: argument mismatch - Haven't checked if this is ANSI C or a SunOS bug. SunOS -Xs works ok. - Behavior is most clearly seen in example: - #define A 1 , 2 - #define C(X,Y,Z) x=X. y=Y. z=Z. - #define D(X,Y,Z) C(X,Y,Z) - D(x,A,z) - Output from preprocessor is: x = x . y = 1 . z = 2 . - #define CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - CFARGT14FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) -*/ -#define CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \ - F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \ - M CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) -#define CFARGT27(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \ - F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \ - F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) F(TL,21,1) \ - F(TM,22,1) F(TN,23,1) F(TO,24,1) F(TP,25,1) F(TQ,26,1) F(TR,27,1) \ - M CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) - -#define CFARGT20(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \ - F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \ - F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \ - F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) \ - S(T1,1) S(T2,2) S(T3,3) S(T4,4) S(T5,5) S(T6,6) S(T7,7) \ - S(T8,8) S(T9,9) S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14) \ - S(TF,15) S(TG,16) S(TH,17) S(TI,18) S(TJ,19) S(TK,20) -#define CFARGTA14(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) \ - F(T1,A1,1,0) F(T2,A2,2,1) F(T3,A3,3,1) F(T4,A4,4,1) F(T5,A5,5,1) F(T6,A6,6,1) \ - F(T7,A7,7,1) F(T8,A8,8,1) F(T9,A9,9,1) F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \ - F(TD,AD,13,1) F(TE,AE,14,1) S(T1,1) S(T2,2) S(T3,3) S(T4,4) \ - S(T5,5) S(T6,6) S(T7,7) S(T8,8) S(T9,9) S(TA,10) \ - S(TB,11) S(TC,12) S(TD,13) S(TE,14) -#if MAX_PREPRO_ARGS>31 -#define CFARGTA20(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \ - F(T1,A1,1,0) F(T2,A2,2,1) F(T3,A3,3,1) F(T4,A4,4,1) F(T5,A5,5,1) F(T6,A6,6,1) \ - F(T7,A7,7,1) F(T8,A8,8,1) F(T9,A9,9,1) F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \ - F(TD,AD,13,1) F(TE,AE,14,1) F(TF,AF,15,1) F(TG,AG,16,1) F(TH,AH,17,1) F(TI,AI,18,1) \ - F(TJ,AJ,19,1) F(TK,AK,20,1) S(T1,1) S(T2,2) S(T3,3) S(T4,4) \ - S(T5,5) S(T6,6) S(T7,7) S(T8,8) S(T9,9) S(TA,10) \ - S(TB,11) S(TC,12) S(TD,13) S(TE,14) S(TF,15) S(TG,16) \ - S(TH,17) S(TI,18) S(TJ,19) S(TK,20) -#define CFARGTA27(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \ - F(T1,A1,1,0) F(T2,A2,2,1) F(T3,A3,3,1) F(T4,A4,4,1) F(T5,A5,5,1) F(T6,A6,6,1) \ - F(T7,A7,7,1) F(T8,A8,8,1) F(T9,A9,9,1) F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \ - F(TD,AD,13,1) F(TE,AE,14,1) F(TF,AF,15,1) F(TG,AG,16,1) F(TH,AH,17,1) F(TI,AI,18,1) \ - F(TJ,AJ,19,1) F(TK,AK,20,1) F(TL,AL,21,1) F(TM,AM,22,1) F(TN,AN,23,1) F(TO,AO,24,1) \ - F(TP,AP,25,1) F(TQ,AQ,26,1) F(TR,AR,27,1) S(T1,1) S(T2,2) S(T3,3) \ - S(T4,4) S(T5,5) S(T6,6) S(T7,7) S(T8,8) S(T9,9) \ - S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14) S(TF,15) \ - S(TG,16) S(TH,17) S(TI,18) S(TJ,19) S(TK,20) S(TL,21) \ - S(TM,22) S(TN,23) S(TO,24) S(TP,25) S(TQ,26) S(TR,27) -#endif -#else -#define CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - F(T1,1,0) S(T1,1) F(T2,2,1) S(T2,2) F(T3,3,1) S(T3,3) F(T4,4,1) S(T4,4) \ - F(T5,5,1) S(T5,5) F(T6,6,1) S(T6,6) F(T7,7,1) S(T7,7) F(T8,8,1) S(T8,8) \ - F(T9,9,1) S(T9,9) F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \ - F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14) -#define CFARGT27(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - F(T1,1,0) S(T1,1) F(T2,2,1) S(T2,2) F(T3,3,1) S(T3,3) F(T4,4,1) S(T4,4) \ - F(T5,5,1) S(T5,5) F(T6,6,1) S(T6,6) F(T7,7,1) S(T7,7) F(T8,8,1) S(T8,8) \ - F(T9,9,1) S(T9,9) F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \ - F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14) F(TF,15,1) S(TF,15) F(TG,16,1) S(TG,16) \ - F(TH,17,1) S(TH,17) F(TI,18,1) S(TI,18) F(TJ,19,1) S(TJ,19) F(TK,20,1) S(TK,20) \ - F(TL,21,1) S(TL,21) F(TM,22,1) S(TM,22) F(TN,23,1) S(TN,23) F(TO,24,1) S(TO,24) \ - F(TP,25,1) S(TP,25) F(TQ,26,1) S(TQ,26) F(TR,27,1) S(TR,27) - -#define CFARGT20(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \ - F(T1,1,0) S(T1,1) F(T2,2,1) S(T2,2) F(T3,3,1) S(T3,3) F(T4,4,1) S(T4,4) \ - F(T5,5,1) S(T5,5) F(T6,6,1) S(T6,6) F(T7,7,1) S(T7,7) F(T8,8,1) S(T8,8) \ - F(T9,9,1) S(T9,9) F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \ - F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14) F(TF,15,1) S(TF,15) F(TG,16,1) S(TG,16) \ - F(TH,17,1) S(TH,17) F(TI,18,1) S(TI,18) F(TJ,19,1) S(TJ,19) F(TK,20,1) S(TK,20) -#define CFARGTA14(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) \ - F(T1,A1,1,0) S(T1,1) F(T2,A2,2,1) S(T2,2) F(T3,A3,3,1) S(T3,3) \ - F(T4,A4,4,1) S(T4,4) F(T5,A5,5,1) S(T5,5) F(T6,A6,6,1) S(T6,6) \ - F(T7,A7,7,1) S(T7,7) F(T8,A8,8,1) S(T8,8) F(T9,A9,9,1) S(T9,9) \ - F(TA,AA,10,1) S(TA,10) F(TB,AB,11,1) S(TB,11) F(TC,AC,12,1) S(TC,12) \ - F(TD,AD,13,1) S(TD,13) F(TE,AE,14,1) S(TE,14) -#if MAX_PREPRO_ARGS>31 -#define CFARGTA20(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \ - F(T1,A1,1,0) S(T1,1) F(T2,A2,2,1) S(T2,2) F(T3,A3,3,1) S(T3,3) \ - F(T4,A4,4,1) S(T4,4) F(T5,A5,5,1) S(T5,5) F(T6,A6,6,1) S(T6,6) \ - F(T7,A7,7,1) S(T7,7) F(T8,A8,8,1) S(T8,8) F(T9,A9,9,1) S(T9,9) \ - F(TA,AA,10,1) S(TA,10) F(TB,AB,11,1) S(TB,11) F(TC,AC,12,1) S(TC,12) \ - F(TD,AD,13,1) S(TD,13) F(TE,AE,14,1) S(TE,14) F(TF,AF,15,1) S(TF,15) \ - F(TG,AG,16,1) S(TG,16) F(TH,AH,17,1) S(TH,17) F(TI,AI,18,1) S(TI,18) \ - F(TJ,AJ,19,1) S(TJ,19) F(TK,AK,20,1) S(TK,20) -#define CFARGTA27(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \ - F(T1,A1,1,0) S(T1,1) F(T2,A2,2,1) S(T2,2) F(T3,A3,3,1) S(T3,3) \ - F(T4,A4,4,1) S(T4,4) F(T5,A5,5,1) S(T5,5) F(T6,A6,6,1) S(T6,6) \ - F(T7,A7,7,1) S(T7,7) F(T8,A8,8,1) S(T8,8) F(T9,A9,9,1) S(T9,9) \ - F(TA,AA,10,1) S(TA,10) F(TB,AB,11,1) S(TB,11) F(TC,AC,12,1) S(TC,12) \ - F(TD,AD,13,1) S(TD,13) F(TE,AE,14,1) S(TE,14) F(TF,AF,15,1) S(TF,15) \ - F(TG,AG,16,1) S(TG,16) F(TH,AH,17,1) S(TH,17) F(TI,AI,18,1) S(TI,18) \ - F(TJ,AJ,19,1) S(TJ,19) F(TK,AK,20,1) S(TK,20) F(TL,AL,21,1) S(TL,21) \ - F(TM,AM,22,1) S(TM,22) F(TN,AN,23,1) S(TN,23) F(TO,AO,24,1) S(TO,24) \ - F(TP,AP,25,1) S(TP,25) F(TQ,AQ,26,1) S(TQ,26) F(TR,AR,27,1) S(TR,27) -#endif -#endif - - -#define PROTOCCALLSFSUB1( UN,LN,T1) \ - PROTOCCALLSFSUB14(UN,LN,T1,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB2( UN,LN,T1,T2) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB3( UN,LN,T1,T2,T3) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB4( UN,LN,T1,T2,T3,T4) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB5( UN,LN,T1,T2,T3,T4,T5) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB6( UN,LN,T1,T2,T3,T4,T5,T6) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB7( UN,LN,T1,T2,T3,T4,T5,T6,T7) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0) -#define PROTOCCALLSFSUB13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0) - - -#define PROTOCCALLSFSUB15(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) \ - PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB16(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) \ - PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB17(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) \ - PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB18(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) \ - PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0) -#define PROTOCCALLSFSUB19(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) \ - PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0) - -#define PROTOCCALLSFSUB21(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) \ - PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB22(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) \ - PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB23(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) \ - PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB24(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) \ - PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,CF_0,CF_0,CF_0) -#define PROTOCCALLSFSUB25(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) \ - PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,CF_0,CF_0) -#define PROTOCCALLSFSUB26(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) \ - PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,CF_0) - - -#ifndef FCALLSC_QUALIFIER -#ifdef VISUAL_CPLUSPLUS -#define FCALLSC_QUALIFIER __stdcall -#else -#define FCALLSC_QUALIFIER -#endif -#endif - -#ifdef __cplusplus -#define CFextern extern "C" -#else -#define CFextern extern -#endif - - -#ifdef CFSUBASFUN -#define PROTOCCALLSFSUB0(UN,LN) \ - PROTOCCALLSFFUN0( VOID,UN,LN) -#define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - PROTOCCALLSFFUN14(VOID,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) -#define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)\ - PROTOCCALLSFFUN20(VOID,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) -#define PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)\ - PROTOCCALLSFFUN27(VOID,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) -#else -/* Note: Prevent compiler warnings, null #define PROTOCCALLSFSUB14/20 after - #include-ing cfortran.h if calling the FORTRAN wrapper within the same - source code where the wrapper is created. */ -#define PROTOCCALLSFSUB0(UN,LN) _(VOID,_cfPU)(CFC_(UN,LN))(); -#ifndef __CF__KnR -#define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - _(VOID,_cfPU)(CFC_(UN,LN))( CFARGT14(NCF,KCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ); -#define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)\ - _(VOID,_cfPU)(CFC_(UN,LN))( CFARGT20(NCF,KCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) ); -#define PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)\ - _(VOID,_cfPU)(CFC_(UN,LN))( CFARGT27(NCF,KCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) ); -#else -#define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - PROTOCCALLSFSUB0(UN,LN) -#define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \ - PROTOCCALLSFSUB0(UN,LN) -#define PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - PROTOCCALLSFSUB0(UN,LN) -#endif -#endif - - -#ifdef OLD_VAXC /* Allow %CC-I-PARAMNOTUSED. */ -#pragma standard -#endif - - -#define CCALLSFSUB1( UN,LN,T1, A1) \ - CCALLSFSUB5 (UN,LN,T1,CF_0,CF_0,CF_0,CF_0,A1,0,0,0,0) -#define CCALLSFSUB2( UN,LN,T1,T2, A1,A2) \ - CCALLSFSUB5 (UN,LN,T1,T2,CF_0,CF_0,CF_0,A1,A2,0,0,0) -#define CCALLSFSUB3( UN,LN,T1,T2,T3, A1,A2,A3) \ - CCALLSFSUB5 (UN,LN,T1,T2,T3,CF_0,CF_0,A1,A2,A3,0,0) -#define CCALLSFSUB4( UN,LN,T1,T2,T3,T4, A1,A2,A3,A4)\ - CCALLSFSUB5 (UN,LN,T1,T2,T3,T4,CF_0,A1,A2,A3,A4,0) -#define CCALLSFSUB5( UN,LN,T1,T2,T3,T4,T5, A1,A2,A3,A4,A5) \ - CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,0,0,0,0,0) -#define CCALLSFSUB6( UN,LN,T1,T2,T3,T4,T5,T6, A1,A2,A3,A4,A5,A6) \ - CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,0,0,0,0) -#define CCALLSFSUB7( UN,LN,T1,T2,T3,T4,T5,T6,T7, A1,A2,A3,A4,A5,A6,A7) \ - CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,0,0,0) -#define CCALLSFSUB8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8, A1,A2,A3,A4,A5,A6,A7,A8) \ - CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,0,0) -#define CCALLSFSUB9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,A1,A2,A3,A4,A5,A6,A7,A8,A9)\ - CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,0) -#define CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA)\ - CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,0,0,0,0) -#define CCALLSFSUB11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB)\ - CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,0,0,0) -#define CCALLSFSUB12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC)\ - CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,0,0) -#define CCALLSFSUB13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD)\ - CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,0) - -#ifdef __cplusplus -#define CPPPROTOCLSFSUB0( UN,LN) -#define CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) -#define CPPPROTOCLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) -#define CPPPROTOCLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) -#else -#define CPPPROTOCLSFSUB0(UN,LN) \ - PROTOCCALLSFSUB0(UN,LN) -#define CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) -#define CPPPROTOCLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \ - PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) -#define CPPPROTOCLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) -#endif - -#ifdef CFSUBASFUN -#define CCALLSFSUB0(UN,LN) CCALLSFFUN0(UN,LN) -#define CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\ - CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) -#else -/* do{...}while(0) allows if(a==b) FORT(); else BORT(); */ -#define CCALLSFSUB0( UN,LN) do{CPPPROTOCLSFSUB0(UN,LN) CFC_(UN,LN)();}while(0) -#define CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\ -do{VVCF(T1,A1,B1) VVCF(T2,A2,B2) VVCF(T3,A3,B3) VVCF(T4,A4,B4) VVCF(T5,A5,B5) \ - VVCF(T6,A6,B6) VVCF(T7,A7,B7) VVCF(T8,A8,B8) VVCF(T9,A9,B9) VVCF(TA,AA,B10) \ - VVCF(TB,AB,B11) VVCF(TC,AC,B12) VVCF(TD,AD,B13) VVCF(TE,AE,B14) \ - CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - ACF(LN,T1,A1,1) ACF(LN,T2,A2,2) ACF(LN,T3,A3,3) \ - ACF(LN,T4,A4,4) ACF(LN,T5,A5,5) ACF(LN,T6,A6,6) ACF(LN,T7,A7,7) \ - ACF(LN,T8,A8,8) ACF(LN,T9,A9,9) ACF(LN,TA,AA,10) ACF(LN,TB,AB,11) \ - ACF(LN,TC,AC,12) ACF(LN,TD,AD,13) ACF(LN,TE,AE,14) \ - CFC_(UN,LN)( CFARGTA14(AACF,JCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) );\ - WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) \ - WCF(T6,A6,6) WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,AA,10) \ - WCF(TB,AB,11) WCF(TC,AC,12) WCF(TD,AD,13) WCF(TE,AE,14) }while(0) -#endif - - -#if MAX_PREPRO_ARGS>31 -#define CCALLSFSUB15(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF)\ - CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,0,0,0,0,0) -#define CCALLSFSUB16(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG)\ - CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,0,0,0,0) -#define CCALLSFSUB17(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH)\ - CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,0,0,0) -#define CCALLSFSUB18(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI)\ - CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,0,0) -#define CCALLSFSUB19(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ)\ - CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,0) - -#ifdef CFSUBASFUN -#define CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \ - TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \ - CCALLSFFUN20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \ - TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) -#else -#define CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \ - TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \ -do{VVCF(T1,A1,B1) VVCF(T2,A2,B2) VVCF(T3,A3,B3) VVCF(T4,A4,B4) VVCF(T5,A5,B5) \ - VVCF(T6,A6,B6) VVCF(T7,A7,B7) VVCF(T8,A8,B8) VVCF(T9,A9,B9) VVCF(TA,AA,B10) \ - VVCF(TB,AB,B11) VVCF(TC,AC,B12) VVCF(TD,AD,B13) VVCF(TE,AE,B14) VVCF(TF,AF,B15) \ - VVCF(TG,AG,B16) VVCF(TH,AH,B17) VVCF(TI,AI,B18) VVCF(TJ,AJ,B19) VVCF(TK,AK,B20) \ - CPPPROTOCLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \ - ACF(LN,T1,A1,1) ACF(LN,T2,A2,2) ACF(LN,T3,A3,3) ACF(LN,T4,A4,4) \ - ACF(LN,T5,A5,5) ACF(LN,T6,A6,6) ACF(LN,T7,A7,7) ACF(LN,T8,A8,8) \ - ACF(LN,T9,A9,9) ACF(LN,TA,AA,10) ACF(LN,TB,AB,11) ACF(LN,TC,AC,12) \ - ACF(LN,TD,AD,13) ACF(LN,TE,AE,14) ACF(LN,TF,AF,15) ACF(LN,TG,AG,16) \ - ACF(LN,TH,AH,17) ACF(LN,TI,AI,18) ACF(LN,TJ,AJ,19) ACF(LN,TK,AK,20) \ - CFC_(UN,LN)( CFARGTA20(AACF,JCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) ); \ - WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) WCF(T6,A6,6) \ - WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,AA,10) WCF(TB,AB,11) WCF(TC,AC,12) \ - WCF(TD,AD,13) WCF(TE,AE,14) WCF(TF,AF,15) WCF(TG,AG,16) WCF(TH,AH,17) WCF(TI,AI,18) \ - WCF(TJ,AJ,19) WCF(TK,AK,20) }while(0) -#endif -#endif /* MAX_PREPRO_ARGS */ - -#if MAX_PREPRO_ARGS>31 -#define CCALLSFSUB21(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL)\ - CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,0,0,0,0,0,0) -#define CCALLSFSUB22(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM)\ - CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,0,0,0,0,0) -#define CCALLSFSUB23(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN)\ - CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,0,0,0,0) -#define CCALLSFSUB24(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO)\ - CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,0,0,0) -#define CCALLSFSUB25(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP)\ - CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,0,0) -#define CCALLSFSUB26(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ)\ - CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,0) - -#ifdef CFSUBASFUN -#define CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR, \ - A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \ - CCALLSFFUN27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR, \ - A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) -#else -#define CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR, \ - A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \ -do{VVCF(T1,A1,B1) VVCF(T2,A2,B2) VVCF(T3,A3,B3) VVCF(T4,A4,B4) VVCF(T5,A5,B5) \ - VVCF(T6,A6,B6) VVCF(T7,A7,B7) VVCF(T8,A8,B8) VVCF(T9,A9,B9) VVCF(TA,AA,B10) \ - VVCF(TB,AB,B11) VVCF(TC,AC,B12) VVCF(TD,AD,B13) VVCF(TE,AE,B14) VVCF(TF,AF,B15) \ - VVCF(TG,AG,B16) VVCF(TH,AH,B17) VVCF(TI,AI,B18) VVCF(TJ,AJ,B19) VVCF(TK,AK,B20) \ - VVCF(TL,AL,B21) VVCF(TM,AM,B22) VVCF(TN,AN,B23) VVCF(TO,AO,B24) VVCF(TP,AP,B25) \ - VVCF(TQ,AQ,B26) VVCF(TR,AR,B27) \ - CPPPROTOCLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - ACF(LN,T1,A1,1) ACF(LN,T2,A2,2) ACF(LN,T3,A3,3) ACF(LN,T4,A4,4) \ - ACF(LN,T5,A5,5) ACF(LN,T6,A6,6) ACF(LN,T7,A7,7) ACF(LN,T8,A8,8) \ - ACF(LN,T9,A9,9) ACF(LN,TA,AA,10) ACF(LN,TB,AB,11) ACF(LN,TC,AC,12) \ - ACF(LN,TD,AD,13) ACF(LN,TE,AE,14) ACF(LN,TF,AF,15) ACF(LN,TG,AG,16) \ - ACF(LN,TH,AH,17) ACF(LN,TI,AI,18) ACF(LN,TJ,AJ,19) ACF(LN,TK,AK,20) \ - ACF(LN,TL,AL,21) ACF(LN,TM,AM,22) ACF(LN,TN,AN,23) ACF(LN,TO,AO,24) \ - ACF(LN,TP,AP,25) ACF(LN,TQ,AQ,26) ACF(LN,TR,AR,27) \ - CFC_(UN,LN)( CFARGTA27(AACF,JCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR,\ - A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) ); \ - WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) WCF(T6,A6,6) \ - WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,AA,10) WCF(TB,AB,11) WCF(TC,AC,12) \ - WCF(TD,AD,13) WCF(TE,AE,14) WCF(TF,AF,15) WCF(TG,AG,16) WCF(TH,AH,17) WCF(TI,AI,18) \ - WCF(TJ,AJ,19) WCF(TK,AK,20) WCF(TL,AL,21) WCF(TM,AM,22) WCF(TN,AN,23) WCF(TO,AO,24) \ - WCF(TP,AP,25) WCF(TQ,AQ,26) WCF(TR,AR,27) }while(0) -#endif -#endif /* MAX_PREPRO_ARGS */ - -/*-------------------------------------------------------------------------*/ - -/* UTILITIES FOR C TO CALL FORTRAN FUNCTIONS */ - -/*N.B. PROTOCCALLSFFUNn(..) generates code, whether or not the FORTRAN - function is called. Therefore, especially for creator's of C header files - for large FORTRAN libraries which include many functions, to reduce - compile time and object code size, it may be desirable to create - preprocessor directives to allow users to create code for only those - functions which they use. */ - -/* The following defines the maximum length string that a function can return. - Of course it may be undefine-d and re-define-d before individual - PROTOCCALLSFFUNn(..) as required. It would also be nice to have this derived - from the individual machines' limits. */ -#define MAX_LEN_FORTRAN_FUNCTION_STRING 0x4FE - -/* The following defines a character used by CFORTRAN.H to flag the end of a - string coming out of a FORTRAN routine. */ -#define CFORTRAN_NON_CHAR 0x7F - -#ifdef OLD_VAXC /* Prevent %CC-I-PARAMNOTUSED. */ -#pragma nostandard -#endif - -#define _SEP_(TN,C,cfCOMMA) _(__SEP_,C)(TN,cfCOMMA) -#define __SEP_0(TN,cfCOMMA) -#define __SEP_1(TN,cfCOMMA) _Icf(2,SEP,TN,cfCOMMA,0) -#define INT_cfSEP(T,B) _(A,B) -#define INTV_cfSEP(T,B) INT_cfSEP(T,B) -#define INTVV_cfSEP(T,B) INT_cfSEP(T,B) -#define INTVVV_cfSEP(T,B) INT_cfSEP(T,B) -#define INTVVVV_cfSEP(T,B) INT_cfSEP(T,B) -#define INTVVVVV_cfSEP(T,B) INT_cfSEP(T,B) -#define INTVVVVVV_cfSEP(T,B) INT_cfSEP(T,B) -#define INTVVVVVVV_cfSEP(T,B) INT_cfSEP(T,B) -#define PINT_cfSEP(T,B) INT_cfSEP(T,B) -#define PVOID_cfSEP(T,B) INT_cfSEP(T,B) -#define ROUTINE_cfSEP(T,B) INT_cfSEP(T,B) -#define SIMPLE_cfSEP(T,B) INT_cfSEP(T,B) -#define VOID_cfSEP(T,B) INT_cfSEP(T,B) /* For FORTRAN calls C subr.s.*/ -#define STRING_cfSEP(T,B) INT_cfSEP(T,B) -#define STRINGV_cfSEP(T,B) INT_cfSEP(T,B) -#define PSTRING_cfSEP(T,B) INT_cfSEP(T,B) -#define PSTRINGV_cfSEP(T,B) INT_cfSEP(T,B) -#define PNSTRING_cfSEP(T,B) INT_cfSEP(T,B) -#define PPSTRING_cfSEP(T,B) INT_cfSEP(T,B) -#define ZTRINGV_cfSEP(T,B) INT_cfSEP(T,B) -#define PZTRINGV_cfSEP(T,B) INT_cfSEP(T,B) - -#if defined(SIGNED_BYTE) || !defined(UNSIGNED_BYTE) -#ifdef OLD_VAXC -#define INTEGER_BYTE char /* Old VAXC barfs on 'signed char' */ -#else -#define INTEGER_BYTE signed char /* default */ -#endif -#else -#define INTEGER_BYTE unsigned char -#endif -#define BYTEVVVVVVV_cfTYPE INTEGER_BYTE -#define DOUBLEVVVVVVV_cfTYPE DOUBLE_PRECISION -#define FLOATVVVVVVV_cfTYPE FORTRAN_REAL -#define INTVVVVVVV_cfTYPE int -#define LOGICALVVVVVVV_cfTYPE int -#define LONGVVVVVVV_cfTYPE long -#define SHORTVVVVVVV_cfTYPE short -#define PBYTE_cfTYPE INTEGER_BYTE -#define PDOUBLE_cfTYPE DOUBLE_PRECISION -#define PFLOAT_cfTYPE FORTRAN_REAL -#define PINT_cfTYPE int -#define PLOGICAL_cfTYPE int -#define PLONG_cfTYPE long -#define PSHORT_cfTYPE short - -#define CFARGS0(A,T,V,W,X,Y,Z) _3(T,_cf,A) -#define CFARGS1(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V) -#define CFARGS2(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W) -#define CFARGS3(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W,X) -#define CFARGS4(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W,X,Y) -#define CFARGS5(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W,X,Y,Z) - -#define _Icf(N,T,I,X,Y) _(I,_cfINT)(N,T,I,X,Y,0) -#define _Icf4(N,T,I,X,Y,Z) _(I,_cfINT)(N,T,I,X,Y,Z) -#define BYTE_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z) -#define DOUBLE_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INT,B,X,Y,Z,0) -#define FLOAT_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z) -#define INT_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z) -#define LOGICAL_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z) -#define LONG_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z) -#define SHORT_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z) -#define PBYTE_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z) -#define PDOUBLE_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,PINT,B,X,Y,Z,0) -#define PFLOAT_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z) -#define PINT_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z) -#define PLOGICAL_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z) -#define PLONG_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z) -#define PSHORT_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z) -#define BYTEV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z) -#define BYTEVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z) -#define BYTEVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z) -#define BYTEVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) -#define BYTEVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) -#define BYTEVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) -#define BYTEVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) -#define DOUBLEV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTV,B,X,Y,Z,0) -#define DOUBLEVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVV,B,X,Y,Z,0) -#define DOUBLEVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVV,B,X,Y,Z,0) -#define DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVV,B,X,Y,Z,0) -#define DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVVV,B,X,Y,Z,0) -#define DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVVVV,B,X,Y,Z,0) -#define DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVVVVV,B,X,Y,Z,0) -#define FLOATV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z) -#define FLOATVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z) -#define FLOATVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z) -#define FLOATVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) -#define FLOATVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) -#define FLOATVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) -#define FLOATVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) -#define INTV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z) -#define INTVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z) -#define INTVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z) -#define INTVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) -#define INTVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) -#define INTVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) -#define INTVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) -#define LOGICALV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z) -#define LOGICALVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z) -#define LOGICALVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z) -#define LOGICALVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) -#define LOGICALVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) -#define LOGICALVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) -#define LOGICALVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) -#define LONGV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z) -#define LONGVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z) -#define LONGVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z) -#define LONGVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) -#define LONGVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) -#define LONGVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) -#define LONGVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) -#define SHORTV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z) -#define SHORTVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z) -#define SHORTVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z) -#define SHORTVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) -#define SHORTVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) -#define SHORTVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) -#define SHORTVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) -#define PVOID_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,B,B,X,Y,Z,0) -#define ROUTINE_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -/*CRAY coughs on the first, - i.e. the usual trouble of not being able to - define macros to macros with arguments. - New ultrix is worse, it coughs on all such uses. - */ -/*#define SIMPLE_cfINT PVOID_cfINT*/ -#define SIMPLE_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define VOID_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define STRING_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define STRINGV_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define PSTRING_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define PSTRINGV_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define PNSTRING_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define PPSTRING_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define ZTRINGV_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define PZTRINGV_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z) -#define CF_0_cfINT(N,A,B,X,Y,Z) - - -#define UCF(TN,I,C) _SEP_(TN,C,cfCOMMA) _Icf(2,U,TN,_(A,I),0) -#define UUCF(TN,I,C) _SEP_(TN,C,cfCOMMA) _SEP_(TN,1,I) -#define UUUCF(TN,I,C) _SEP_(TN,C,cfCOLON) _Icf(2,U,TN,_(A,I),0) -#define INT_cfU(T,A) _(T,VVVVVVV_cfTYPE) A -#define INTV_cfU(T,A) _(T,VVVVVV_cfTYPE) * A -#define INTVV_cfU(T,A) _(T,VVVVV_cfTYPE) * A -#define INTVVV_cfU(T,A) _(T,VVVV_cfTYPE) * A -#define INTVVVV_cfU(T,A) _(T,VVV_cfTYPE) * A -#define INTVVVVV_cfU(T,A) _(T,VV_cfTYPE) * A -#define INTVVVVVV_cfU(T,A) _(T,V_cfTYPE) * A -#define INTVVVVVVV_cfU(T,A) _(T,_cfTYPE) * A -#define PINT_cfU(T,A) _(T,_cfTYPE) * A -#define PVOID_cfU(T,A) void *A -#define ROUTINE_cfU(T,A) void (*A)(CF_NULL_PROTO) -#define VOID_cfU(T,A) void A /* Needed for C calls FORTRAN sub.s. */ -#define STRING_cfU(T,A) char *A /* via VOID and wrapper. */ -#define STRINGV_cfU(T,A) char *A -#define PSTRING_cfU(T,A) char *A -#define PSTRINGV_cfU(T,A) char *A -#define ZTRINGV_cfU(T,A) char *A -#define PZTRINGV_cfU(T,A) char *A - -/* VOID breaks U into U and UU. */ -#define INT_cfUU(T,A) _(T,VVVVVVV_cfTYPE) A -#define VOID_cfUU(T,A) /* Needed for FORTRAN calls C sub.s. */ -#define STRING_cfUU(T,A) char *A - - -#define BYTE_cfPU(A) CFextern INTEGER_BYTE FCALLSC_QUALIFIER A -#define DOUBLE_cfPU(A) CFextern DOUBLE_PRECISION FCALLSC_QUALIFIER A -#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT)) -#define FLOAT_cfPU(A) CFextern FORTRAN_REAL FCALLSC_QUALIFIER A -#else -#define FLOAT_cfPU(A) CFextern FLOATFUNCTIONTYPE FCALLSC_QUALIFIER A -#endif -#define INT_cfPU(A) CFextern int FCALLSC_QUALIFIER A -#define LOGICAL_cfPU(A) CFextern int FCALLSC_QUALIFIER A -#define LONG_cfPU(A) CFextern long FCALLSC_QUALIFIER A -#define SHORT_cfPU(A) CFextern short FCALLSC_QUALIFIER A -#define STRING_cfPU(A) CFextern void FCALLSC_QUALIFIER A -#define VOID_cfPU(A) CFextern void FCALLSC_QUALIFIER A - -#define BYTE_cfE INTEGER_BYTE A0; -#define DOUBLE_cfE DOUBLE_PRECISION A0; -#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT)) -#define FLOAT_cfE FORTRAN_REAL A0; -#else -#define FLOAT_cfE FORTRAN_REAL AA0; FLOATFUNCTIONTYPE A0; -#endif -#define INT_cfE int A0; -#define LOGICAL_cfE int A0; -#define LONG_cfE long A0; -#define SHORT_cfE short A0; -#define VOID_cfE -#ifdef vmsFortran -#define STRING_cfE static char AA0[1+MAX_LEN_FORTRAN_FUNCTION_STRING]; \ - static fstring A0 = \ - {MAX_LEN_FORTRAN_FUNCTION_STRING,DSC$K_DTYPE_T,DSC$K_CLASS_S,AA0};\ - memset(AA0, CFORTRAN_NON_CHAR, MAX_LEN_FORTRAN_FUNCTION_STRING);\ - *(AA0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0'; -#else -#ifdef CRAYFortran -#define STRING_cfE static char AA0[1+MAX_LEN_FORTRAN_FUNCTION_STRING]; \ - static _fcd A0; *(AA0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';\ - memset(AA0,CFORTRAN_NON_CHAR, MAX_LEN_FORTRAN_FUNCTION_STRING);\ - A0 = _cptofcd(AA0,MAX_LEN_FORTRAN_FUNCTION_STRING); -#else -/* 'cc: SC3.0.1 13 Jul 1994' barfs on char A0[0x4FE+1]; - * char A0[0x4FE +1]; char A0[1+0x4FE]; are both OK. */ -#define STRING_cfE static char A0[1+MAX_LEN_FORTRAN_FUNCTION_STRING]; \ - memset(A0, CFORTRAN_NON_CHAR, \ - MAX_LEN_FORTRAN_FUNCTION_STRING); \ - *(A0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0'; -#endif -#endif -/* ESTRING must use static char. array which is guaranteed to exist after - function returns. */ - -/* N.B.i) The diff. for 0 (Zero) and >=1 arguments. - ii)That the following create an unmatched bracket, i.e. '(', which - must of course be matched in the call. - iii)Commas must be handled very carefully */ -#define INT_cfGZ(T,UN,LN) A0=CFC_(UN,LN)( -#define VOID_cfGZ(T,UN,LN) CFC_(UN,LN)( -#ifdef vmsFortran -#define STRING_cfGZ(T,UN,LN) CFC_(UN,LN)(&A0 -#else -#if defined(CRAYFortran) || defined(AbsoftUNIXFortran) || defined(AbsoftProFortran) -#define STRING_cfGZ(T,UN,LN) CFC_(UN,LN)( A0 -#else -#define STRING_cfGZ(T,UN,LN) CFC_(UN,LN)( A0,MAX_LEN_FORTRAN_FUNCTION_STRING -#endif -#endif - -#define INT_cfG(T,UN,LN) INT_cfGZ(T,UN,LN) -#define VOID_cfG(T,UN,LN) VOID_cfGZ(T,UN,LN) -#define STRING_cfG(T,UN,LN) STRING_cfGZ(T,UN,LN), /*, is only diff. from _cfG*/ - -#define BYTEVVVVVVV_cfPP -#define INTVVVVVVV_cfPP /* These complement FLOATVVVVVVV_cfPP. */ -#define DOUBLEVVVVVVV_cfPP -#define LOGICALVVVVVVV_cfPP -#define LONGVVVVVVV_cfPP -#define SHORTVVVVVVV_cfPP -#define PBYTE_cfPP -#define PINT_cfPP -#define PDOUBLE_cfPP -#define PLOGICAL_cfPP -#define PLONG_cfPP -#define PSHORT_cfPP -#define PFLOAT_cfPP FLOATVVVVVVV_cfPP - -#define BCF(TN,AN,C) _SEP_(TN,C,cfCOMMA) _Icf(2,B,TN,AN,0) -#define INT_cfB(T,A) (_(T,VVVVVVV_cfTYPE)) A -#define INTV_cfB(T,A) A -#define INTVV_cfB(T,A) (A)[0] -#define INTVVV_cfB(T,A) (A)[0][0] -#define INTVVVV_cfB(T,A) (A)[0][0][0] -#define INTVVVVV_cfB(T,A) (A)[0][0][0][0] -#define INTVVVVVV_cfB(T,A) (A)[0][0][0][0][0] -#define INTVVVVVVV_cfB(T,A) (A)[0][0][0][0][0][0] -#define PINT_cfB(T,A) _(T,_cfPP)&A -#define STRING_cfB(T,A) (char *) A -#define STRINGV_cfB(T,A) (char *) A -#define PSTRING_cfB(T,A) (char *) A -#define PSTRINGV_cfB(T,A) (char *) A -#define PVOID_cfB(T,A) (void *) A -#define ROUTINE_cfB(T,A) (cfCAST_FUNCTION)A -#define ZTRINGV_cfB(T,A) (char *) A -#define PZTRINGV_cfB(T,A) (char *) A - -#define SCF(TN,NAME,I,A) _(TN,_cfSTR)(3,S,NAME,I,A,0,0) -#define DEFAULT_cfS(M,I,A) -#define LOGICAL_cfS(M,I,A) -#define PLOGICAL_cfS(M,I,A) -#define STRING_cfS(M,I,A) ,sizeof(A) -#define STRINGV_cfS(M,I,A) ,( (unsigned)0xFFFF*firstindexlength(A) \ - +secondindexlength(A)) -#define PSTRING_cfS(M,I,A) ,sizeof(A) -#define PSTRINGV_cfS(M,I,A) STRINGV_cfS(M,I,A) -#define ZTRINGV_cfS(M,I,A) -#define PZTRINGV_cfS(M,I,A) - -#define HCF(TN,I) _(TN,_cfSTR)(3,H,cfCOMMA, H,_(C,I),0,0) -#define HHCF(TN,I) _(TN,_cfSTR)(3,H,cfCOMMA,HH,_(C,I),0,0) -#define HHHCF(TN,I) _(TN,_cfSTR)(3,H,cfCOLON, H,_(C,I),0,0) -#define H_CF_SPECIAL unsigned -#define HH_CF_SPECIAL -#define DEFAULT_cfH(M,I,A) -#define LOGICAL_cfH(S,U,B) -#define PLOGICAL_cfH(S,U,B) -#define STRING_cfH(S,U,B) _(A,S) _(U,_CF_SPECIAL) B -#define STRINGV_cfH(S,U,B) STRING_cfH(S,U,B) -#define PSTRING_cfH(S,U,B) STRING_cfH(S,U,B) -#define PSTRINGV_cfH(S,U,B) STRING_cfH(S,U,B) -#define PNSTRING_cfH(S,U,B) STRING_cfH(S,U,B) -#define PPSTRING_cfH(S,U,B) STRING_cfH(S,U,B) -#define ZTRINGV_cfH(S,U,B) -#define PZTRINGV_cfH(S,U,B) - -/* Need VOID_cfSTR because Absoft forced function types go through _cfSTR. */ -/* No spaces inside expansion. They screws up macro catenation kludge. */ -#define VOID_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define BYTE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define DOUBLE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define FLOAT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define INT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LOGICAL_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,LOGICAL,A,B,C,D,E) -#define LONG_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define SHORT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define BYTEV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define BYTEVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define BYTEVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define BYTEVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define BYTEVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define BYTEVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define BYTEVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define DOUBLEV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define DOUBLEVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define DOUBLEVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define DOUBLEVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define DOUBLEVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define DOUBLEVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define DOUBLEVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define FLOATV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define FLOATVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define FLOATVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define FLOATVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define FLOATVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define FLOATVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define FLOATVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define INTV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define INTVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define INTVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define INTVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define INTVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define INTVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define INTVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LOGICALV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LOGICALVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LOGICALVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LOGICALVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LOGICALVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LOGICALVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LOGICALVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LONGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LONGVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LONGVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LONGVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LONGVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LONGVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define LONGVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define SHORTV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define SHORTVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define SHORTVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define SHORTVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define SHORTVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define SHORTVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define SHORTVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define PBYTE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define PDOUBLE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define PFLOAT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define PINT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define PLOGICAL_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PLOGICAL,A,B,C,D,E) -#define PLONG_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define PSHORT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define STRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,STRING,A,B,C,D,E) -#define PSTRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PSTRING,A,B,C,D,E) -#define STRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,STRINGV,A,B,C,D,E) -#define PSTRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PSTRINGV,A,B,C,D,E) -#define PNSTRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PNSTRING,A,B,C,D,E) -#define PPSTRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PPSTRING,A,B,C,D,E) -#define PVOID_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define ROUTINE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define SIMPLE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) -#define ZTRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,ZTRINGV,A,B,C,D,E) -#define PZTRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PZTRINGV,A,B,C,D,E) -#define CF_0_cfSTR(N,T,A,B,C,D,E) - -/* See ACF table comments, which explain why CCF was split into two. */ -#define CCF(NAME,TN,I) _(TN,_cfSTR)(5,C,NAME,I,_(A,I),_(B,I),_(C,I)) -#define DEFAULT_cfC(M,I,A,B,C) -#define LOGICAL_cfC(M,I,A,B,C) A=C2FLOGICAL( A); -#define PLOGICAL_cfC(M,I,A,B,C) *A=C2FLOGICAL(*A); -#ifdef vmsFortran -#define STRING_cfC(M,I,A,B,C) (B.clen=strlen(A),B.f.dsc$a_pointer=A, \ - C==sizeof(char*)||C==(unsigned)(B.clen+1)?B.f.dsc$w_length=B.clen: \ - (memset((A)+B.clen,' ',C-B.clen-1),A[B.f.dsc$w_length=C-1]='\0')); - /* PSTRING_cfC to beware of array A which does not contain any \0. */ -#define PSTRING_cfC(M,I,A,B,C) (B.dsc$a_pointer=A, C==sizeof(char*) ? \ - B.dsc$w_length=strlen(A): (A[C-1]='\0',B.dsc$w_length=strlen(A), \ - memset((A)+B.dsc$w_length,' ',C-B.dsc$w_length-1), B.dsc$w_length=C-1)); -#else -#define STRING_cfC(M,I,A,B,C) (B.clen=strlen(A), \ - C==sizeof(char*)||C==(unsigned)(B.clen+1)?B.flen=B.clen: \ - (memset((A)+B.clen,' ',C-B.clen-1),A[B.flen=C-1]='\0')); -#define PSTRING_cfC(M,I,A,B,C) (C==sizeof(char*)? B=strlen(A): \ - (A[C-1]='\0',B=strlen(A),memset((A)+B,' ',C-B-1),B=C-1)); -#endif - /* For CRAYFortran for (P)STRINGV_cfC, B.fs is set, but irrelevant. */ -#define STRINGV_cfC(M,I,A,B,C) \ - AATRINGV_cfA( A,B,(C/0xFFFF)*(C%0xFFFF),C/0xFFFF,C%0xFFFF) -#define PSTRINGV_cfC(M,I,A,B,C) \ - APATRINGV_cfA( A,B,(C/0xFFFF)*(C%0xFFFF),C/0xFFFF,C%0xFFFF) -#define ZTRINGV_cfC(M,I,A,B,C) \ - AATRINGV_cfA( A,B, (_3(M,_ELEMS_,I))*((_3(M,_ELEMLEN_,I))+1), \ - (_3(M,_ELEMS_,I)), (_3(M,_ELEMLEN_,I))+1 ) -#define PZTRINGV_cfC(M,I,A,B,C) \ - APATRINGV_cfA( A,B, (_3(M,_ELEMS_,I))*((_3(M,_ELEMLEN_,I))+1), \ - (_3(M,_ELEMS_,I)), (_3(M,_ELEMLEN_,I))+1 ) - -#define BYTE_cfCCC(A,B) &A -#define DOUBLE_cfCCC(A,B) &A -#if !defined(__CF__KnR) -#define FLOAT_cfCCC(A,B) &A - /* Although the VAX doesn't, at least the */ -#else /* HP and K&R mips promote float arg.'s of */ -#define FLOAT_cfCCC(A,B) &B /* unprototyped functions to double. Cannot */ -#endif /* use A here to pass the argument to FORTRAN. */ -#define INT_cfCCC(A,B) &A -#define LOGICAL_cfCCC(A,B) &A -#define LONG_cfCCC(A,B) &A -#define SHORT_cfCCC(A,B) &A -#define PBYTE_cfCCC(A,B) A -#define PDOUBLE_cfCCC(A,B) A -#define PFLOAT_cfCCC(A,B) A -#define PINT_cfCCC(A,B) A -#define PLOGICAL_cfCCC(A,B) B=A /* B used to keep a common W table. */ -#define PLONG_cfCCC(A,B) A -#define PSHORT_cfCCC(A,B) A - -#define CCCF(TN,I,M) _SEP_(TN,M,cfCOMMA) _Icf(3,CC,TN,_(A,I),_(B,I)) -#define INT_cfCC(T,A,B) _(T,_cfCCC)(A,B) -#define INTV_cfCC(T,A,B) A -#define INTVV_cfCC(T,A,B) A -#define INTVVV_cfCC(T,A,B) A -#define INTVVVV_cfCC(T,A,B) A -#define INTVVVVV_cfCC(T,A,B) A -#define INTVVVVVV_cfCC(T,A,B) A -#define INTVVVVVVV_cfCC(T,A,B) A -#define PINT_cfCC(T,A,B) _(T,_cfCCC)(A,B) -#define PVOID_cfCC(T,A,B) A -#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran) -#define ROUTINE_cfCC(T,A,B) &A -#else -#define ROUTINE_cfCC(T,A,B) A -#endif -#define SIMPLE_cfCC(T,A,B) A -#ifdef vmsFortran -#define STRING_cfCC(T,A,B) &B.f -#define STRINGV_cfCC(T,A,B) &B -#define PSTRING_cfCC(T,A,B) &B -#define PSTRINGV_cfCC(T,A,B) &B -#else -#ifdef CRAYFortran -#define STRING_cfCC(T,A,B) _cptofcd(A,B.flen) -#define STRINGV_cfCC(T,A,B) _cptofcd(B.s,B.flen) -#define PSTRING_cfCC(T,A,B) _cptofcd(A,B) -#define PSTRINGV_cfCC(T,A,B) _cptofcd(A,B.flen) -#else -#define STRING_cfCC(T,A,B) A -#define STRINGV_cfCC(T,A,B) B.fs -#define PSTRING_cfCC(T,A,B) A -#define PSTRINGV_cfCC(T,A,B) B.fs -#endif -#endif -#define ZTRINGV_cfCC(T,A,B) STRINGV_cfCC(T,A,B) -#define PZTRINGV_cfCC(T,A,B) PSTRINGV_cfCC(T,A,B) - -#define BYTE_cfX return A0; -#define DOUBLE_cfX return A0; -#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT)) -#define FLOAT_cfX return A0; -#else -#define FLOAT_cfX ASSIGNFLOAT(AA0,A0); return AA0; -#endif -#define INT_cfX return A0; -#define LOGICAL_cfX return F2CLOGICAL(A0); -#define LONG_cfX return A0; -#define SHORT_cfX return A0; -#define VOID_cfX return ; -#if defined(vmsFortran) || defined(CRAYFortran) -#define STRING_cfX return kill_trailing( \ - kill_trailing(AA0,CFORTRAN_NON_CHAR),' '); -#else -#define STRING_cfX return kill_trailing( \ - kill_trailing( A0,CFORTRAN_NON_CHAR),' '); -#endif - -#define CFFUN(NAME) _(__cf__,NAME) - -/* Note that we don't use LN here, but we keep it for consistency. */ -#define CCALLSFFUN0(UN,LN) CFFUN(UN)() - -#ifdef OLD_VAXC /* Allow %CC-I-PARAMNOTUSED. */ -#pragma standard -#endif - -#define CCALLSFFUN1( UN,LN,T1, A1) \ - CCALLSFFUN5 (UN,LN,T1,CF_0,CF_0,CF_0,CF_0,A1,0,0,0,0) -#define CCALLSFFUN2( UN,LN,T1,T2, A1,A2) \ - CCALLSFFUN5 (UN,LN,T1,T2,CF_0,CF_0,CF_0,A1,A2,0,0,0) -#define CCALLSFFUN3( UN,LN,T1,T2,T3, A1,A2,A3) \ - CCALLSFFUN5 (UN,LN,T1,T2,T3,CF_0,CF_0,A1,A2,A3,0,0) -#define CCALLSFFUN4( UN,LN,T1,T2,T3,T4, A1,A2,A3,A4)\ - CCALLSFFUN5 (UN,LN,T1,T2,T3,T4,CF_0,A1,A2,A3,A4,0) -#define CCALLSFFUN5( UN,LN,T1,T2,T3,T4,T5, A1,A2,A3,A4,A5) \ - CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,0,0,0,0,0) -#define CCALLSFFUN6( UN,LN,T1,T2,T3,T4,T5,T6, A1,A2,A3,A4,A5,A6) \ - CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,0,0,0,0) -#define CCALLSFFUN7( UN,LN,T1,T2,T3,T4,T5,T6,T7, A1,A2,A3,A4,A5,A6,A7) \ - CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,0,0,0) -#define CCALLSFFUN8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8, A1,A2,A3,A4,A5,A6,A7,A8) \ - CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,0,0) -#define CCALLSFFUN9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,A1,A2,A3,A4,A5,A6,A7,A8,A9)\ - CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,0) -#define CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA)\ - CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,0,0,0,0) -#define CCALLSFFUN11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB)\ - CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,0,0,0) -#define CCALLSFFUN12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC)\ - CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,0,0) -#define CCALLSFFUN13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD)\ - CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,0) - -#define CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\ -((CFFUN(UN)( BCF(T1,A1,0) BCF(T2,A2,1) BCF(T3,A3,1) BCF(T4,A4,1) BCF(T5,A5,1) \ - BCF(T6,A6,1) BCF(T7,A7,1) BCF(T8,A8,1) BCF(T9,A9,1) BCF(TA,AA,1) \ - BCF(TB,AB,1) BCF(TC,AC,1) BCF(TD,AD,1) BCF(TE,AE,1) \ - SCF(T1,LN,1,A1) SCF(T2,LN,2,A2) SCF(T3,LN,3,A3) SCF(T4,LN,4,A4) \ - SCF(T5,LN,5,A5) SCF(T6,LN,6,A6) SCF(T7,LN,7,A7) SCF(T8,LN,8,A8) \ - SCF(T9,LN,9,A9) SCF(TA,LN,10,AA) SCF(TB,LN,11,AB) SCF(TC,LN,12,AC) \ - SCF(TD,LN,13,AD) SCF(TE,LN,14,AE)))) - -/* N.B. Create a separate function instead of using (call function, function -value here) because in order to create the variables needed for the input -arg.'s which may be const.'s one has to do the creation within {}, but these -can never be placed within ()'s. Therefore one must create wrapper functions. -gcc, on the other hand may be able to avoid the wrapper functions. */ - -/* Prototypes are needed to correctly handle the value returned correctly. N.B. -Can only have prototype arg.'s with difficulty, a la G... table since FORTRAN -functions returning strings have extra arg.'s. Don't bother, since this only -causes a compiler warning to come up when one uses FCALLSCFUNn and CCALLSFFUNn -for the same function in the same source code. Something done by the experts in -debugging only.*/ - -#define PROTOCCALLSFFUN0(F,UN,LN) \ -_(F,_cfPU)( CFC_(UN,LN))(CF_NULL_PROTO); \ -static _Icf(2,U,F,CFFUN(UN),0)() {_(F,_cfE) _Icf(3,GZ,F,UN,LN) ABSOFT_cf1(F));_(F,_cfX)} - -#define PROTOCCALLSFFUN1( T0,UN,LN,T1) \ - PROTOCCALLSFFUN5 (T0,UN,LN,T1,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFFUN2( T0,UN,LN,T1,T2) \ - PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,CF_0,CF_0,CF_0) -#define PROTOCCALLSFFUN3( T0,UN,LN,T1,T2,T3) \ - PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,T3,CF_0,CF_0) -#define PROTOCCALLSFFUN4( T0,UN,LN,T1,T2,T3,T4) \ - PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,T3,T4,CF_0) -#define PROTOCCALLSFFUN5( T0,UN,LN,T1,T2,T3,T4,T5) \ - PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFFUN6( T0,UN,LN,T1,T2,T3,T4,T5,T6) \ - PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFFUN7( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7) \ - PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0) -#define PROTOCCALLSFFUN8( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \ - PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0) -#define PROTOCCALLSFFUN9( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \ - PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0) -#define PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \ - PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0) -#define PROTOCCALLSFFUN11(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \ - PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0) -#define PROTOCCALLSFFUN12(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \ - PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0) -#define PROTOCCALLSFFUN13(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \ - PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0) - -/* HP/UX 9.01 cc requires the blank between '_Icf(3,G,T0,UN,LN) CCCF(T1,1,0)' */ - -#ifndef __CF__KnR -#define PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - _(T0,_cfPU)(CFC_(UN,LN))(CF_NULL_PROTO); static _Icf(2,U,T0,CFFUN(UN),0)( \ - CFARGT14FS(UCF,HCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ) \ -{ CFARGT14S(VCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) _(T0,_cfE) \ - CCF(LN,T1,1) CCF(LN,T2,2) CCF(LN,T3,3) CCF(LN,T4,4) CCF(LN,T5,5) \ - CCF(LN,T6,6) CCF(LN,T7,7) CCF(LN,T8,8) CCF(LN,T9,9) CCF(LN,TA,10) \ - CCF(LN,TB,11) CCF(LN,TC,12) CCF(LN,TD,13) CCF(LN,TE,14) _Icf(3,G,T0,UN,LN) \ - CFARGT14(CCCF,JCF,ABSOFT_cf1(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)); \ - WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) \ - WCF(T6,A6,6) WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,A10,10) \ - WCF(TB,A11,11) WCF(TC,A12,12) WCF(TD,A13,13) WCF(TE,A14,14) _(T0,_cfX)} -#else -#define PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - _(T0,_cfPU)(CFC_(UN,LN))(CF_NULL_PROTO); static _Icf(2,U,T0,CFFUN(UN),0)( \ - CFARGT14FS(UUCF,HHCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ) \ - CFARGT14FS(UUUCF,HHHCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ; \ -{ CFARGT14S(VCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) _(T0,_cfE) \ - CCF(LN,T1,1) CCF(LN,T2,2) CCF(LN,T3,3) CCF(LN,T4,4) CCF(LN,T5,5) \ - CCF(LN,T6,6) CCF(LN,T7,7) CCF(LN,T8,8) CCF(LN,T9,9) CCF(LN,TA,10) \ - CCF(LN,TB,11) CCF(LN,TC,12) CCF(LN,TD,13) CCF(LN,TE,14) _Icf(3,G,T0,UN,LN) \ - CFARGT14(CCCF,JCF,ABSOFT_cf1(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)); \ - WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) \ - WCF(T6,A6,6) WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,A10,10) \ - WCF(TB,A11,11) WCF(TC,A12,12) WCF(TD,A13,13) WCF(TE,A14,14) _(T0,_cfX)} -#endif - -/*-------------------------------------------------------------------------*/ - -/* UTILITIES FOR FORTRAN TO CALL C ROUTINES */ - -#ifdef OLD_VAXC /* Prevent %CC-I-PARAMNOTUSED. */ -#pragma nostandard -#endif - -#if defined(vmsFortran) || defined(CRAYFortran) -#define DCF(TN,I) -#define DDCF(TN,I) -#define DDDCF(TN,I) -#else -#define DCF(TN,I) HCF(TN,I) -#define DDCF(TN,I) HHCF(TN,I) -#define DDDCF(TN,I) HHHCF(TN,I) -#endif - -#define QCF(TN,I) _(TN,_cfSTR)(1,Q,_(B,I), 0,0,0,0) -#define DEFAULT_cfQ(B) -#define LOGICAL_cfQ(B) -#define PLOGICAL_cfQ(B) -#define STRINGV_cfQ(B) char *B; unsigned int _(B,N); -#define STRING_cfQ(B) char *B=NULL; -#define PSTRING_cfQ(B) char *B=NULL; -#define PSTRINGV_cfQ(B) STRINGV_cfQ(B) -#define PNSTRING_cfQ(B) char *B=NULL; -#define PPSTRING_cfQ(B) - -#ifdef __sgi /* Else SGI gives warning 182 contrary to its C LRM A.17.7 */ -#define ROUTINE_orig *(void**)& -#else -#define ROUTINE_orig (void *) -#endif - -#define ROUTINE_1 ROUTINE_orig -#define ROUTINE_2 ROUTINE_orig -#define ROUTINE_3 ROUTINE_orig -#define ROUTINE_4 ROUTINE_orig -#define ROUTINE_5 ROUTINE_orig -#define ROUTINE_6 ROUTINE_orig -#define ROUTINE_7 ROUTINE_orig -#define ROUTINE_8 ROUTINE_orig -#define ROUTINE_9 ROUTINE_orig -#define ROUTINE_10 ROUTINE_orig -#define ROUTINE_11 ROUTINE_orig -#define ROUTINE_12 ROUTINE_orig -#define ROUTINE_13 ROUTINE_orig -#define ROUTINE_14 ROUTINE_orig -#define ROUTINE_15 ROUTINE_orig -#define ROUTINE_16 ROUTINE_orig -#define ROUTINE_17 ROUTINE_orig -#define ROUTINE_18 ROUTINE_orig -#define ROUTINE_19 ROUTINE_orig -#define ROUTINE_20 ROUTINE_orig -#define ROUTINE_21 ROUTINE_orig -#define ROUTINE_22 ROUTINE_orig -#define ROUTINE_23 ROUTINE_orig -#define ROUTINE_24 ROUTINE_orig -#define ROUTINE_25 ROUTINE_orig -#define ROUTINE_26 ROUTINE_orig -#define ROUTINE_27 ROUTINE_orig - -#define TCF(NAME,TN,I,M) _SEP_(TN,M,cfCOMMA) _(TN,_cfT)(NAME,I,_(A,I),_(B,I),_(C,I)) -#define BYTE_cfT(M,I,A,B,D) *A -#define DOUBLE_cfT(M,I,A,B,D) *A -#define FLOAT_cfT(M,I,A,B,D) *A -#define INT_cfT(M,I,A,B,D) *A -#define LOGICAL_cfT(M,I,A,B,D) F2CLOGICAL(*A) -#define LONG_cfT(M,I,A,B,D) *A -#define SHORT_cfT(M,I,A,B,D) *A -#define BYTEV_cfT(M,I,A,B,D) A -#define DOUBLEV_cfT(M,I,A,B,D) A -#define FLOATV_cfT(M,I,A,B,D) VOIDP A -#define INTV_cfT(M,I,A,B,D) A -#define LOGICALV_cfT(M,I,A,B,D) A -#define LONGV_cfT(M,I,A,B,D) A -#define SHORTV_cfT(M,I,A,B,D) A -#define BYTEVV_cfT(M,I,A,B,D) (void *)A /* We have to cast to void *,*/ -#define BYTEVVV_cfT(M,I,A,B,D) (void *)A /* since we don't know the */ -#define BYTEVVVV_cfT(M,I,A,B,D) (void *)A /* dimensions of the array. */ -#define BYTEVVVVV_cfT(M,I,A,B,D) (void *)A /* i.e. Unfortunately, can't */ -#define BYTEVVVVVV_cfT(M,I,A,B,D) (void *)A /* check that the type */ -#define BYTEVVVVVVV_cfT(M,I,A,B,D) (void *)A /* matches the prototype. */ -#define DOUBLEVV_cfT(M,I,A,B,D) (void *)A -#define DOUBLEVVV_cfT(M,I,A,B,D) (void *)A -#define DOUBLEVVVV_cfT(M,I,A,B,D) (void *)A -#define DOUBLEVVVVV_cfT(M,I,A,B,D) (void *)A -#define DOUBLEVVVVVV_cfT(M,I,A,B,D) (void *)A -#define DOUBLEVVVVVVV_cfT(M,I,A,B,D) (void *)A -#define FLOATVV_cfT(M,I,A,B,D) (void *)A -#define FLOATVVV_cfT(M,I,A,B,D) (void *)A -#define FLOATVVVV_cfT(M,I,A,B,D) (void *)A -#define FLOATVVVVV_cfT(M,I,A,B,D) (void *)A -#define FLOATVVVVVV_cfT(M,I,A,B,D) (void *)A -#define FLOATVVVVVVV_cfT(M,I,A,B,D) (void *)A -#define INTVV_cfT(M,I,A,B,D) (void *)A -#define INTVVV_cfT(M,I,A,B,D) (void *)A -#define INTVVVV_cfT(M,I,A,B,D) (void *)A -#define INTVVVVV_cfT(M,I,A,B,D) (void *)A -#define INTVVVVVV_cfT(M,I,A,B,D) (void *)A -#define INTVVVVVVV_cfT(M,I,A,B,D) (void *)A -#define LOGICALVV_cfT(M,I,A,B,D) (void *)A -#define LOGICALVVV_cfT(M,I,A,B,D) (void *)A -#define LOGICALVVVV_cfT(M,I,A,B,D) (void *)A -#define LOGICALVVVVV_cfT(M,I,A,B,D) (void *)A -#define LOGICALVVVVVV_cfT(M,I,A,B,D) (void *)A -#define LOGICALVVVVVVV_cfT(M,I,A,B,D) (void *)A -#define LONGVV_cfT(M,I,A,B,D) (void *)A -#define LONGVVV_cfT(M,I,A,B,D) (void *)A -#define LONGVVVV_cfT(M,I,A,B,D) (void *)A -#define LONGVVVVV_cfT(M,I,A,B,D) (void *)A -#define LONGVVVVVV_cfT(M,I,A,B,D) (void *)A -#define LONGVVVVVVV_cfT(M,I,A,B,D) (void *)A -#define SHORTVV_cfT(M,I,A,B,D) (void *)A -#define SHORTVVV_cfT(M,I,A,B,D) (void *)A -#define SHORTVVVV_cfT(M,I,A,B,D) (void *)A -#define SHORTVVVVV_cfT(M,I,A,B,D) (void *)A -#define SHORTVVVVVV_cfT(M,I,A,B,D) (void *)A -#define SHORTVVVVVVV_cfT(M,I,A,B,D) (void *)A -#define PBYTE_cfT(M,I,A,B,D) A -#define PDOUBLE_cfT(M,I,A,B,D) A -#define PFLOAT_cfT(M,I,A,B,D) VOIDP A -#define PINT_cfT(M,I,A,B,D) A -#define PLOGICAL_cfT(M,I,A,B,D) ((*A=F2CLOGICAL(*A)),A) -#define PLONG_cfT(M,I,A,B,D) A -#define PSHORT_cfT(M,I,A,B,D) A -#define PVOID_cfT(M,I,A,B,D) A -#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran) -#define ROUTINE_cfT(M,I,A,B,D) _(ROUTINE_,I) (*A) -#else -#define ROUTINE_cfT(M,I,A,B,D) _(ROUTINE_,I) A -#endif -/* A == pointer to the characters - D == length of the string, or of an element in an array of strings - E == number of elements in an array of strings */ -#define TTSTR( A,B,D) \ - ((B=_cf_malloc(D+1))[D]='\0', memcpy(B,A,D), kill_trailing(B,' ')) -#define TTTTSTR( A,B,D) (!(D<4||A[0]||A[1]||A[2]||A[3]))?NULL: \ - memchr(A,'\0',D) ?A : TTSTR(A,B,D) -#define TTTTSTRV( A,B,D,E) (_(B,N)=E,B=_cf_malloc(_(B,N)*(D+1)), (void *) \ - vkill_trailing(f2cstrv(A,B,D+1, _(B,N)*(D+1)), D+1,_(B,N)*(D+1),' ')) -#ifdef vmsFortran -#define STRING_cfT(M,I,A,B,D) TTTTSTR( A->dsc$a_pointer,B,A->dsc$w_length) -#define STRINGV_cfT(M,I,A,B,D) TTTTSTRV(A->dsc$a_pointer, B, \ - A->dsc$w_length , A->dsc$l_m[0]) -#define PSTRING_cfT(M,I,A,B,D) TTSTR( A->dsc$a_pointer,B,A->dsc$w_length) -#define PPSTRING_cfT(M,I,A,B,D) A->dsc$a_pointer -#else -#ifdef CRAYFortran -#define STRING_cfT(M,I,A,B,D) TTTTSTR( _fcdtocp(A),B,_fcdlen(A)) -#define STRINGV_cfT(M,I,A,B,D) TTTTSTRV(_fcdtocp(A),B,_fcdlen(A), \ - num_elem(_fcdtocp(A),_fcdlen(A),_3(M,_STRV_A,I))) -#define PSTRING_cfT(M,I,A,B,D) TTSTR( _fcdtocp(A),B,_fcdlen(A)) -#define PPSTRING_cfT(M,I,A,B,D) _fcdtocp(A) -#else -#define STRING_cfT(M,I,A,B,D) TTTTSTR( A,B,D) -#define STRINGV_cfT(M,I,A,B,D) TTTTSTRV(A,B,D, num_elem(A,D,_3(M,_STRV_A,I))) -#define PSTRING_cfT(M,I,A,B,D) TTSTR( A,B,D) -#define PPSTRING_cfT(M,I,A,B,D) A -#endif -#endif -#define PNSTRING_cfT(M,I,A,B,D) STRING_cfT(M,I,A,B,D) -#define PSTRINGV_cfT(M,I,A,B,D) STRINGV_cfT(M,I,A,B,D) -#define CF_0_cfT(M,I,A,B,D) - -#define RCF(TN,I) _(TN,_cfSTR)(3,R,_(A,I),_(B,I),_(C,I),0,0) -#define DEFAULT_cfR(A,B,D) -#define LOGICAL_cfR(A,B,D) -#define PLOGICAL_cfR(A,B,D) *A=C2FLOGICAL(*A); -#define STRING_cfR(A,B,D) if (B) _cf_free(B); -#define STRINGV_cfR(A,B,D) _cf_free(B); -/* A and D as defined above for TSTRING(V) */ -#define RRRRPSTR( A,B,D) if (B) memcpy(A,B, _cfMIN(strlen(B),D)), \ - (D>strlen(B)?memset(A+strlen(B),' ', D-strlen(B)):0), _cf_free(B); -#define RRRRPSTRV(A,B,D) c2fstrv(B,A,D+1,(D+1)*_(B,N)), _cf_free(B); -#ifdef vmsFortran -#define PSTRING_cfR(A,B,D) RRRRPSTR( A->dsc$a_pointer,B,A->dsc$w_length) -#define PSTRINGV_cfR(A,B,D) RRRRPSTRV(A->dsc$a_pointer,B,A->dsc$w_length) -#else -#ifdef CRAYFortran -#define PSTRING_cfR(A,B,D) RRRRPSTR( _fcdtocp(A),B,_fcdlen(A)) -#define PSTRINGV_cfR(A,B,D) RRRRPSTRV(_fcdtocp(A),B,_fcdlen(A)) -#else -#define PSTRING_cfR(A,B,D) RRRRPSTR( A,B,D) -#define PSTRINGV_cfR(A,B,D) RRRRPSTRV(A,B,D) -#endif -#endif -#define PNSTRING_cfR(A,B,D) PSTRING_cfR(A,B,D) -#define PPSTRING_cfR(A,B,D) - -#define BYTE_cfFZ(UN,LN) INTEGER_BYTE FCALLSC_QUALIFIER fcallsc(UN,LN)( -#define DOUBLE_cfFZ(UN,LN) DOUBLE_PRECISION FCALLSC_QUALIFIER fcallsc(UN,LN)( -#define INT_cfFZ(UN,LN) int FCALLSC_QUALIFIER fcallsc(UN,LN)( -#define LOGICAL_cfFZ(UN,LN) int FCALLSC_QUALIFIER fcallsc(UN,LN)( -#define LONG_cfFZ(UN,LN) long FCALLSC_QUALIFIER fcallsc(UN,LN)( -#define SHORT_cfFZ(UN,LN) short FCALLSC_QUALIFIER fcallsc(UN,LN)( -#define VOID_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)( -#ifndef __CF__KnR -/* The void is req'd by the Apollo, to make this an ANSI function declaration. - The Apollo promotes K&R float functions to double. */ -#define FLOAT_cfFZ(UN,LN) FORTRAN_REAL FCALLSC_QUALIFIER fcallsc(UN,LN)(void -#ifdef vmsFortran -#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(fstring *AS -#else -#ifdef CRAYFortran -#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(_fcd AS -#else -#if defined(AbsoftUNIXFortran) || defined(AbsoftProFortran) -#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(char *AS -#else -#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(char *AS, unsigned D0 -#endif -#endif -#endif -#else -#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT)) -#define FLOAT_cfFZ(UN,LN) FORTRAN_REAL FCALLSC_QUALIFIER fcallsc(UN,LN)( -#else -#define FLOAT_cfFZ(UN,LN) FLOATFUNCTIONTYPE FCALLSC_QUALIFIER fcallsc(UN,LN)( -#endif -#if defined(vmsFortran) || defined(CRAYFortran) || defined(AbsoftUNIXFortran) -#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(AS -#else -#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(AS, D0 -#endif -#endif - -#define BYTE_cfF(UN,LN) BYTE_cfFZ(UN,LN) -#define DOUBLE_cfF(UN,LN) DOUBLE_cfFZ(UN,LN) -#ifndef __CF_KnR -#define FLOAT_cfF(UN,LN) FORTRAN_REAL FCALLSC_QUALIFIER fcallsc(UN,LN)( -#else -#define FLOAT_cfF(UN,LN) FLOAT_cfFZ(UN,LN) -#endif -#define INT_cfF(UN,LN) INT_cfFZ(UN,LN) -#define LOGICAL_cfF(UN,LN) LOGICAL_cfFZ(UN,LN) -#define LONG_cfF(UN,LN) LONG_cfFZ(UN,LN) -#define SHORT_cfF(UN,LN) SHORT_cfFZ(UN,LN) -#define VOID_cfF(UN,LN) VOID_cfFZ(UN,LN) -#define STRING_cfF(UN,LN) STRING_cfFZ(UN,LN), - -#define INT_cfFF -#define VOID_cfFF -#ifdef vmsFortran -#define STRING_cfFF fstring *AS; -#else -#ifdef CRAYFortran -#define STRING_cfFF _fcd AS; -#else -#define STRING_cfFF char *AS; unsigned D0; -#endif -#endif - -#define INT_cfL A0= -#define STRING_cfL A0= -#define VOID_cfL - -#define INT_cfK -#define VOID_cfK -/* KSTRING copies the string into the position provided by the caller. */ -#ifdef vmsFortran -#define STRING_cfK \ - memcpy(AS->dsc$a_pointer,A0,_cfMIN(AS->dsc$w_length,(A0==NULL?0:strlen(A0))));\ - AS->dsc$w_length>(A0==NULL?0:strlen(A0))? \ - memset(AS->dsc$a_pointer+(A0==NULL?0:strlen(A0)),' ', \ - AS->dsc$w_length-(A0==NULL?0:strlen(A0))):0; -#else -#ifdef CRAYFortran -#define STRING_cfK \ - memcpy(_fcdtocp(AS),A0, _cfMIN(_fcdlen(AS),(A0==NULL?0:strlen(A0))) ); \ - _fcdlen(AS)>(A0==NULL?0:strlen(A0))? \ - memset(_fcdtocp(AS)+(A0==NULL?0:strlen(A0)),' ', \ - _fcdlen(AS)-(A0==NULL?0:strlen(A0))):0; -#else -#define STRING_cfK memcpy(AS,A0, _cfMIN(D0,(A0==NULL?0:strlen(A0))) ); \ - D0>(A0==NULL?0:strlen(A0))?memset(AS+(A0==NULL?0:strlen(A0)), \ - ' ', D0-(A0==NULL?0:strlen(A0))):0; -#endif -#endif - -/* Note that K.. and I.. can't be combined since K.. has to access data before -R.., in order for functions returning strings which are also passed in as -arguments to work correctly. Note that R.. frees and hence may corrupt the -string. */ -#define BYTE_cfI return A0; -#define DOUBLE_cfI return A0; -#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT)) -#define FLOAT_cfI return A0; -#else -#define FLOAT_cfI RETURNFLOAT(A0); -#endif -#define INT_cfI return A0; -#ifdef hpuxFortran800 -/* Incredibly, functions must return true as 1, elsewhere .true.==0x01000000. */ -#define LOGICAL_cfI return ((A0)?1:0); -#else -#define LOGICAL_cfI return C2FLOGICAL(A0); -#endif -#define LONG_cfI return A0; -#define SHORT_cfI return A0; -#define STRING_cfI return ; -#define VOID_cfI return ; - -#ifdef OLD_VAXC /* Allow %CC-I-PARAMNOTUSED. */ -#pragma standard -#endif - -#define FCALLSCSUB0( CN,UN,LN) FCALLSCFUN0(VOID,CN,UN,LN) -#define FCALLSCSUB1( CN,UN,LN,T1) FCALLSCFUN1(VOID,CN,UN,LN,T1) -#define FCALLSCSUB2( CN,UN,LN,T1,T2) FCALLSCFUN2(VOID,CN,UN,LN,T1,T2) -#define FCALLSCSUB3( CN,UN,LN,T1,T2,T3) FCALLSCFUN3(VOID,CN,UN,LN,T1,T2,T3) -#define FCALLSCSUB4( CN,UN,LN,T1,T2,T3,T4) \ - FCALLSCFUN4(VOID,CN,UN,LN,T1,T2,T3,T4) -#define FCALLSCSUB5( CN,UN,LN,T1,T2,T3,T4,T5) \ - FCALLSCFUN5(VOID,CN,UN,LN,T1,T2,T3,T4,T5) -#define FCALLSCSUB6( CN,UN,LN,T1,T2,T3,T4,T5,T6) \ - FCALLSCFUN6(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6) -#define FCALLSCSUB7( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7) \ - FCALLSCFUN7(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7) -#define FCALLSCSUB8( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \ - FCALLSCFUN8(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) -#define FCALLSCSUB9( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \ - FCALLSCFUN9(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) -#define FCALLSCSUB10(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \ - FCALLSCFUN10(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) -#define FCALLSCSUB11(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \ - FCALLSCFUN11(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) -#define FCALLSCSUB12(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \ - FCALLSCFUN12(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) -#define FCALLSCSUB13(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \ - FCALLSCFUN13(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) -#define FCALLSCSUB14(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - FCALLSCFUN14(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) -#define FCALLSCSUB15(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) \ - FCALLSCFUN15(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) -#define FCALLSCSUB16(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) \ - FCALLSCFUN16(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) -#define FCALLSCSUB17(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) \ - FCALLSCFUN17(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) -#define FCALLSCSUB18(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) \ - FCALLSCFUN18(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) -#define FCALLSCSUB19(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) \ - FCALLSCFUN19(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) -#define FCALLSCSUB20(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \ - FCALLSCFUN20(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) -#define FCALLSCSUB21(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) \ - FCALLSCFUN21(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) -#define FCALLSCSUB22(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) \ - FCALLSCFUN22(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) -#define FCALLSCSUB23(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) \ - FCALLSCFUN23(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) -#define FCALLSCSUB24(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) \ - FCALLSCFUN24(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) -#define FCALLSCSUB25(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) \ - FCALLSCFUN25(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) -#define FCALLSCSUB26(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) \ - FCALLSCFUN26(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) -#define FCALLSCSUB27(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - FCALLSCFUN27(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) - - -#define FCALLSCFUN1( T0,CN,UN,LN,T1) \ - FCALLSCFUN5 (T0,CN,UN,LN,T1,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN2( T0,CN,UN,LN,T1,T2) \ - FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,CF_0,CF_0,CF_0) -#define FCALLSCFUN3( T0,CN,UN,LN,T1,T2,T3) \ - FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,T3,CF_0,CF_0) -#define FCALLSCFUN4( T0,CN,UN,LN,T1,T2,T3,T4) \ - FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,T3,T4,CF_0) -#define FCALLSCFUN5( T0,CN,UN,LN,T1,T2,T3,T4,T5) \ - FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN6( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6) \ - FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN7( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7) \ - FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0) -#define FCALLSCFUN8( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \ - FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0) -#define FCALLSCFUN9( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \ - FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0) -#define FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \ - FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN11(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \ - FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0) -#define FCALLSCFUN12(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \ - FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0) -#define FCALLSCFUN13(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \ - FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0) - - -#define FCALLSCFUN15(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) \ - FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN16(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) \ - FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN17(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) \ - FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0) -#define FCALLSCFUN18(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) \ - FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0) -#define FCALLSCFUN19(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) \ - FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0) -#define FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \ - FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN21(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) \ - FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN22(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) \ - FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,CF_0,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN23(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) \ - FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,CF_0,CF_0,CF_0,CF_0) -#define FCALLSCFUN24(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) \ - FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,CF_0,CF_0,CF_0) -#define FCALLSCFUN25(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) \ - FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,CF_0,CF_0) -#define FCALLSCFUN26(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) \ - FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,CF_0) - - -#ifndef __CF__KnR -#define FCALLSCFUN0(T0,CN,UN,LN) CFextern _(T0,_cfFZ)(UN,LN) ABSOFT_cf2(T0)) \ - {_Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN(); _Icf(0,K,T0,0,0) _(T0,_cfI)} - -#define FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - CFextern _(T0,_cfF)(UN,LN) \ - CFARGT14(NCF,DCF,ABSOFT_cf2(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ) \ - { CFARGT14S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) \ - TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \ - TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \ - TCF(LN,TD,13,1) TCF(LN,TE,14,1) ); _Icf(0,K,T0,0,0) \ - CFARGT14S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) _(T0,_cfI) } - -#define FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - CFextern _(T0,_cfF)(UN,LN) \ - CFARGT27(NCF,DCF,ABSOFT_cf2(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) ) \ - { CFARGT27S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) \ - TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \ - TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \ - TCF(LN,TD,13,1) TCF(LN,TE,14,1) TCF(LN,TF,15,1) TCF(LN,TG,16,1) TCF(LN,TH,17,1) \ - TCF(LN,TI,18,1) TCF(LN,TJ,19,1) TCF(LN,TK,20,1) TCF(LN,TL,21,1) TCF(LN,TM,22,1) \ - TCF(LN,TN,23,1) TCF(LN,TO,24,1) TCF(LN,TP,25,1) TCF(LN,TQ,26,1) TCF(LN,TR,27,1) ); _Icf(0,K,T0,0,0) \ - CFARGT27S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) _(T0,_cfI) } - -#else -#define FCALLSCFUN0(T0,CN,UN,LN) CFextern _(T0,_cfFZ)(UN,LN) ABSOFT_cf3(T0)) _Icf(0,FF,T0,0,0)\ - {_Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN(); _Icf(0,K,T0,0,0) _(T0,_cfI)} - -#define FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - CFextern _(T0,_cfF)(UN,LN) \ - CFARGT14(NNCF,DDCF,ABSOFT_cf3(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)) _Icf(0,FF,T0,0,0) \ - CFARGT14FS(NNNCF,DDDCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE); \ - { CFARGT14S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \ - _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) \ - TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \ - TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \ - TCF(LN,TD,13,1) TCF(LN,TE,14,1) ); _Icf(0,K,T0,0,0) \ - CFARGT14S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) _(T0,_cfI)} - -#define FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - CFextern _(T0,_cfF)(UN,LN) \ - CFARGT27(NNCF,DDCF,ABSOFT_cf3(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)) _Icf(0,FF,T0,0,0) \ - CFARGT27FS(NNNCF,DDDCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR); \ - { CFARGT27S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \ - _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) \ - TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \ - TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \ - TCF(LN,TD,13,1) TCF(LN,TE,14,1) TCF(LN,TF,15,1) TCF(LN,TG,16,1) TCF(LN,TH,17,1) \ - TCF(LN,TI,18,1) TCF(LN,TJ,19,1) TCF(LN,TK,20,1) TCF(LN,TL,21,1) TCF(LN,TM,22,1) \ - TCF(LN,TN,23,1) TCF(LN,TO,24,1) TCF(LN,TP,25,1) TCF(LN,TQ,26,1) TCF(LN,TR,27,1) ); _Icf(0,K,T0,0,0) \ - CFARGT27S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) _(T0,_cfI)} - -#endif - - -#endif /* __CFORTRAN_LOADED */ diff --git a/millepede/linesrch.f90 b/millepede/linesrch.f90 deleted file mode 100644 index d341f98380..0000000000 --- a/millepede/linesrch.f90 +++ /dev/null @@ -1,347 +0,0 @@ - -! Code converted using TO_F90 by Alan Miller -! Date: 2012-03-16 Time: 11:06:29 - -!> \file -!! Line search. -!! -!! \author Volker Blobel, University Hamburg, 2005-2009 (initial Fortran77 version) -!! \author Claus Kleinwort, DESY (maintenance and developement) -!! -!! \copyright -!! Copyright (c) 2009 - 2015 Deutsches Elektronen-Synchroton, -!! Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n -!! 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. \n\n -!! 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. \n\n -!! You should have received a copy of the GNU Library General Public -!! License along with this program (see the file COPYING.LIB for more -!! details); if not, write to the Free Software Foundation, Inc., -!! 675 Mass Ave, Cambridge, MA 02139, USA. -!! -!! Line search routine with sufficient decrease of slope. -!! -!! In many minimization problems the objective function is close to -!! quadratic, except far from the solution. Close to the minimum the -!! behaviour may be almost quadratic or, due to round-off errors, -!! it may have a non-smooth behaviour, which often complicates any -!! further progress and the recognition of convergence. -!! Round-off errors affect the function value, which may be large and -!! small parameter changes result in small relative changes of the -!! function value. Close to the minimum the gradient becomes small -!! and the behaviour is not so much affected by Round-off errors. -!! -!! CALL PTLDEF(0.0,0.0, 0,0) ! init line search -!! N=... -!! X(.)=... -!! D(.)=... -!! ALPHA=1.0D0 -!! 10 F(X)=... -!! G(X)=... -!! IF(.) S(X)=.. -!! CALL PTLINE(N,X,F,G,D,ALPHA,INFO) -!! IF(INFO.LT.0) GOTO 10 -!! - -!> Line search data. -MODULE linesrch - USE mpdef - - IMPLICIT NONE - - INTEGER(mpi), PARAMETER :: msfd=20 - INTEGER(mpi) :: nsfd !< number of function calls - INTEGER(mpi) :: idgl !< index of smallest negative slope - INTEGER(mpi):: idgr !< index of smallest positive slope - INTEGER(mpi) :: idgm !< index of minimal slope - INTEGER(mpi) :: minf=1 !< min. number of function calls - INTEGER(mpi) :: maxf=5 !< max. number of function calls - INTEGER(mpi) :: lsinfo !< (status) information - REAL(mpd), DIMENSION(4,msfd) :: sfd !< abscissa; function value; slope; predicted zero - REAL(mpd) :: stmx=0.9 !< maximum slope ratio - REAL(mpd) :: gtol !< slope ratio - -END MODULE linesrch - -!> Perform linesearch. -!! -!! \param [in] N dimension of problem -!! \param [in,out] X current iterate -!! \param [in,out] F associated function value -!! \param [in,out] G associated gradient -!! \param [in,out] S search vector -!! \param [out] STEP step factor (initially = 1.0) -!! \param [out] INFO information -!! -!! = -1 repeat function evaluation -!! = 0 input error (e.g. gradient not negative) -!! = 1 convergence reached -!! = 2 convergence assumed, but round-off errors -!! = 3 too many function calls -!! = 4 step factor ALPHA to small (ALPHA <= TOL) -!! - -SUBROUTINE ptline(n,x,f,g,s,step, info) ! - 2 arguments - USE linesrch - - IMPLICIT NONE - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN OUT) :: x(n) - REAL(mpd), INTENT(IN OUT) :: f - REAL(mpd), INTENT(IN OUT) :: g(n) - REAL(mpd), INTENT(IN OUT) :: s(n) - REAL(mpd), INTENT(OUT) :: step - INTEGER(mpi), INTENT(OUT) :: info - - INTEGER(mpi):: i1 - INTEGER(mpi) :: i2 - INTEGER(mpi) :: i ! internal - INTEGER(mpi) :: im ! internal - REAL(mpd) :: alpha ! internal - REAL(mpd) :: dginit ! internal - REAL(mpd) :: dg ! internal - REAL(mpd) :: fsaved ! internal - REAL(mpd) :: tot ! internal - REAL(mpd) :: fp1 ! internal - REAL(mpd) :: fp2 ! internal - SAVE - - ! initialization --------------------------------------------------- - - info=0 ! reset INFO flag - dg=0.0_mpd - DO i=1,n ! - dg=dg-g(i)*s(i) ! DG = scalar product: grad x search - END DO! - - IF(nsfd == 0) THEN ! initial call - dginit=dg ! DG = initial directional gradient - IF(dginit >= 0.0_mpd) GO TO 100 ! error: step not decreasing - step=1.0_mpd ! initial step factor is one - alpha=step ! get initial step factor - tot=0.0_mpd ! reset total step - idgl=1 ! index of smallest negative slope - idgr=0 ! index of smallest positive slope - fsaved=f ! initial Function value - nsfd=1 ! starting point of iteration - sfd(1,1)=0.0 ! abscissa - sfd(2,1)=0.0 ! reference function value - sfd(3,1)=dginit ! slope - sfd(4,1)=0.0 ! predicted zero - im=1 ! optimum - ELSE ! subsequent call - nsfd=nsfd+1 - sfd(1,nsfd)=tot ! abscissa - sfd(2,nsfd)=f-fsaved ! function value difference to reference - sfd(3,nsfd)=dg ! slope - sfd(4,nsfd)=0.0 ! predicted zero (see below) - IF(dg < sfd(3,im)) THEN - im=nsfd - END IF - - ! define interval indices IDGL and IDGR - IF(dg <= 0.0_mpd) THEN - IF(dg >= sfd(3,idgl)) idgl=nsfd - END IF - IF(dg >= 0.0_mpd) THEN ! limit to the right - IF(idgr == 0) idgr=nsfd - IF(dg <= sfd(3,idgr)) idgr=nsfd - END IF - - IF(idgr == 0) THEN - i1=nsfd-1 - i2=nsfd - ELSE - i1=idgl - i2=idgr - END IF - fp1=sfd(3,i1) - fp2=sfd(3,i2) ! interpolation - sfd(4,nsfd)=(sfd(1,i1)*fp2-sfd(1,i2)*fp1)/(fp2-fp1) - - ! convergence tests - IF(nsfd >= minf.AND.ABS(dg) <= ABS(dginit)*gtol) THEN - ! normal convergence return with INFO=1 ---------------------- - alpha=tot+alpha ! total ALPHA is returned - step =alpha - idgm=idgl - IF(idgr /= 0) THEN - IF(sfd(3,idgr)+sfd(3,idgl) < 0.0_mpd) idgm=idgr - END IF - GO TO 101 - END IF - IF(nsfd >= maxf) GO TO 102 ! max number of function calls - alpha=MIN(sfd(4,nsfd),stmx)-tot ! new step from previous - IF(ABS(alpha) < 1.0E-3_mpd.AND.sfd(4,nsfd) > stmx) GO TO 103 - IF(ABS(alpha) < 1.0E-3_mpd) GO TO 104 - END IF - - ! prepare next function call --------------------------------------- - - DO i=1,n - x(i)=x(i)+alpha*s(i) ! step by ALPHA -> new X - END DO - tot=tot+alpha ! - step=tot - info=-1 ! recalculate function and gradient - lsinfo=info - RETURN - - ! error exits ------------------------------------------------------ -104 info=info+1 ! 4: step small -103 info=info+1 ! 3: maximum reached -102 info=info+1 ! 2: too many function calls -101 info=info+1 ! 1: normal convergence - lsinfo=info - im=1 - DO i=1,nsfd - IF(ABS(sfd(3,i)) < ABS(sfd(3,im))) im=i - END DO - alpha=sfd(1,im)-sfd(1,nsfd) - IF(im == nsfd) RETURN ! already at minimum - DO i=1,n - x(i)=x(i)+alpha*s(i) ! step by ALPHA to slope minimum - END DO - f=sfd(2,im)+fsaved ! F at minimum - step=sfd(1,im) ! total step at convergence - IF(im /= 1) RETURN ! improvement - info=5 ! no improvement -100 step=0.0_mpd ! 0: initial slope not negative - lsinfo=info - RETURN -END SUBROUTINE ptline - -!> Initialize line search. -!! -!! \param[in] gtole slope ratio -!! \param[in] stmax total step limit -!! \param[in] minfe minimum number of evaluations -!! \param[in] maxfe maximum number of evaluations -!! -!! --- range ---- default -!! slope ratio 1.0E-4 ... 0.9 0.9 -!! min. F-calls 1 ... 2 1 -!! max. F-calls 2 ... 10 5 -!! - -SUBROUTINE ptldef(gtole,stmax,minfe,maxfe) - USE linesrch - - IMPLICIT NONE - INTEGER(mpi), INTENT(IN) :: minfe - INTEGER(mpi), INTENT(IN) :: maxfe - REAL(mps), INTENT(IN) :: gtole - REAL(mps), INTENT(IN) :: stmax - - gtol=MAX(1.0E-4,MIN(gtole,0.9E0)) ! slope ratio - IF(gtole == 0.0) gtol=0.9_mpd ! default slope ratio - stmx=stmax ! maximum total step - IF(stmx == 0.0_mpd) stmx=10.0_mpd ! default limit - minf=MAX(1,MIN(minfe,msfd-2)) ! minimum number of evaluations - maxf=MAX(2,MIN(maxfe,msfd-1)) ! maximum number of evaluations - IF(maxfe == 0) maxf=5 ! default max number of values - nsfd=0 ! reset -END SUBROUTINE ptldef - -!> Get details. -!! -!! \param[out] NF number of function values -!! \param[out] M index of function value with smallest slope -!! \param[out] SLOPES initial, current, smallest slope -!! \param[out] STEPS initial position, current, smallest step - -SUBROUTINE ptlopt(nf,m,slopes,steps) - USE linesrch - IMPLICIT NONE - - INTEGER(mpi), INTENT(OUT) :: nf - INTEGER(mpi), INTENT(OUT) :: m - REAL(mps), DIMENSION(3), INTENT(OUT) :: slopes - REAL(mps), DIMENSION(3), INTENT(OUT) :: steps - INTEGER(mpi) :: i - - ! ... - nf=nsfd - IF(nsfd == 0) THEN ! no values - m=0 - DO i=1,3 - slopes(i)=0.0 - steps(i) =0.0 - END DO - ELSE ! values exist - m=1 - DO i=1,nsfd - IF(ABS(sfd(3,i)) < ABS(sfd(3,m))) m=i - END DO - slopes(1)=REAL(sfd(3,1)) - slopes(2)=REAL(sfd(3,nsfd)) - slopes(3)=REAL(sfd(3,m)) - steps(1) =REAL(sfd(1,1)) - steps(2) =REAL(sfd(1,nsfd)) - steps(3) =REAL(sfd(1,m)) - END IF -END SUBROUTINE ptlopt - -!> Print line search data. -!! -!! \param[in] lunp unit number - -SUBROUTINE ptlprt(lunp) - USE linesrch - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: im - INTEGER(mpi) :: lun - INTEGER(mpi), INTENT(IN) :: lunp - REAL(mps) :: ratio - CHARACTER (LEN=2) :: tlr - ! ... - lun=lunp - IF(lun == 0) lun=6 - IF(nsfd <= 0) RETURN - WRITE(lun,*) ' ' - WRITE(lun,*) 'PTLINE: line-search method based on slopes', & - ' with sufficient slope-decrease' - WRITE(lun,*) 'PTLDEF: slope ratio limit=',gtol - WRITE(lun,*) 'PTLDEF: maximum step =',stmx - WRITE(lun,*) 'PTLDEF:',minf,' <= nr of calls <=',maxf - WRITE(lun,101) - im=1 - DO i=1,nsfd - IF(ABS(sfd(3,i)) < ABS(sfd(3,im))) im=i - END DO - DO i=1,nsfd - tlr=' ' - IF(i == im) tlr='**' - IF(i == idgl) tlr(1:1)='L' - IF(i == idgr) tlr(2:2)='R' - IF(i == 1) THEN - WRITE(lun,102) i-1, sfd(1,i),tlr,(sfd(j,i),j=2,4) - ELSE - ratio=REAL(ABS(sfd(3,i)/sfd(3,1))) - WRITE(lun,103) i-1, sfd(1,i),tlr,(sfd(j,i),j=2,4),ratio - END IF - - END DO - IF(lsinfo == 0) WRITE(lun,*) & - 'PTLINE: INFO=0 input error (e.g. gradient not negative)' - IF(lsinfo == 1) WRITE(lun,*) 'PTLINE: INFO=1 convergence reached' - IF(lsinfo == 2) WRITE(lun,*) 'PTLINE: INFO=2 too many function calls' - IF(lsinfo == 3) WRITE(lun,*) 'PTLINE: INFO=3 maximum step reached' - IF(lsinfo == 4) WRITE(lun,*) 'PTLINE: INFO=4 step too small (< 0.001)' - WRITE(lun,*) ' ' - -101 FORMAT(' i x F(x) F''(X)', & - ' minimum F''(X)') -102 FORMAT(i3,f12.6,1X,a2,g15.6,g14.6,f12.6,' ratio') -103 FORMAT(i3,f12.6,1X,a2,g15.6,g14.6,f12.6,f10.3) - -END SUBROUTINE ptlprt - diff --git a/millepede/mille.f90 b/millepede/mille.f90 deleted file mode 100644 index b8441d9e9e..0000000000 --- a/millepede/mille.f90 +++ /dev/null @@ -1,185 +0,0 @@ - -! Code converted using TO_F90 by Alan Miller -! Date: 2012-03-03 Time: 17:00:12 - -!> \file -!! Write Millepede-II F-binary record. -!! -!! \author Volker Blobel, University Hamburg, 2005-2009 (initial Fortran77 version) -!! \author Claus Kleinwort, DESY (maintenance and developement) -!! -!! \copyright -!! Copyright (c) 2009 - 2015 Deutsches Elektronen-Synchroton, -!! Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n -!! 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. \n\n -!! 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. \n\n -!! You should have received a copy of the GNU Library General Public -!! License along with this program (see the file COPYING.LIB for more -!! details); if not, write to the Free Software Foundation, Inc., -!! 675 Mass Ave, Cambridge, MA 02139, USA. - -!> Add data block to record. Called from user code. -!! -!! CALL MILLE(...) ! measured value, derivatives (one set) -!! CALL ENDLE ! complete, write record (many sets) -!! (or CALL KILLE ! stop record) -!! -!! The data transmitted by MILLE calls are collected in two arrays, -!! a real array and an integer array, of same length. The collected -!! data are written at the ENDLE call. The content of the arrays: -!! -!! real array integer array -!! 1 0.0 error count (this record) -!! 2 RMEAS, measured value 0 JA -!! 3 local derivative index of local derivative -!! 4 local derivative index of local derivative -!! 5 ... -!! 6 SIGMA, error (>0) 0 JB -!! global derivative label of global derivative -!! global derivative label of global derivative IST -!! RMEAS, measured value 0 -!! local derivative index of local derivative -!! local derivative index of local derivative -!! ... -!! SIGMA, error 0 -!! global derivative label of global derivative -!! global derivative label of global derivative -!! ... -!! NR global derivative label of global derivative -!! -!! The 0's in the integer array allow to recognize the start -!! of a new set, the measured value and the error. The local and -!! the global derivatives are inbetween, with a positive value in -!! the integer array, the index of the local derivative or the -!! label of the global derivative. -!! -!! If more than one output unit is needed: duplicate this subroutine -!! change the entry names to e.g. AMILLE, AENDLE, AKILLE and change -!! the value of LUN and evtl. the dimension parameter in the -!! parameter statements. -!! -!! \param [in] NLC number of local derivatives -!! \param [in] DERLC local derivatives -!! \param [in] NGL number of global derivatives -!! \param [in] DERGL global derivatives -!! \param [in] LABEL labels for global derivatives -!! \param [in] RMEAS measurement -!! \param [in] SIGMA error of measurement - -SUBROUTINE MILLE(nlc,derlc,ngl,dergl,label,rmeas,sigma) ! add data - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: icount - INTEGER(mpi) :: isp - INTEGER(mpi) :: nr - INTEGER(mpi) :: nsp - ! ----------------------------------------------------------------- - - INTEGER(mpi), INTENT(IN) :: nlc - REAL(mps), INTENT(IN) :: derlc(nlc) - INTEGER(mpi), INTENT(IN) :: ngl - REAL(mps), INTENT(IN) :: dergl(ngl) - INTEGER(mpi), INTENT(IN) :: label(ngl) - REAL(mps), INTENT(IN) :: rmeas - REAL(mps), INTENT(IN) :: sigma - INTEGER(mpi), PARAMETER :: lun=51 - INTEGER(mpi), PARAMETER :: ndim=10000 - REAL(mps) :: glder(ndim) ! real data record array - INTEGER(mpi) :: inder(ndim) ! integer data record array - ! ----------------------------------------------------------------- - - SAVE - DATA nr/0/ ! initial record length - DATA icount/0/ - ! ... - IF(sigma <= 0.0) RETURN ! error zero - no measurement - IF(nr == 0) THEN - nr=1 - glder(1)=0.0 - inder(1)=0 ! error counter - isp=0 - END IF - IF(nr+nlc+ngl+2 > ndim) THEN - icount=icount+1 - IF(icount <= 10) THEN - WRITE(*,*) 'Mille warning: data can not be stored' - IF(icount == 10) THEN - WRITE(*,*) 'Mille warning: no further printout' - END IF - END IF - inder(1)=inder(1)+1 ! count errors - RETURN ! record dimension too small - END IF - nr=nr+1 - glder(nr)=rmeas ! measured value - inder(nr)=0 - DO i=1,nlc ! local derivatives - IF(derlc(i) /= 0.0) THEN - nr=nr+1 - glder(nr)=derlc(i) ! derivative of local parameter - inder(nr)=i ! index of local parameter - END IF - END DO - - nr=nr+1 - glder(nr)=sigma ! error of measured value - inder(nr)=0 - DO i=1,ngl ! global derivatives - IF(dergl(i) /= 0.0.AND.label(i) > 0) THEN - nr=nr+1 - glder(nr)=dergl(i) ! derivative of global parameter - inder(nr)=label(i) ! index of global parameter - END IF - END DO - RETURN - - ENTRY MILLSP(nsp,dergl,label) - ! add NSP special words (floating-point and integer) - - ! 0.0 0 - ! -float(NSP) 0 ! indicates special data - ! following NSP floating and NSP integer data - - IF(nsp <= 0.OR.isp /= 0) RETURN - isp=nr - IF(nr == 0) THEN - nr=1 - glder(1)=0.0 - inder(1)=0 ! error counter - END IF - IF(nr+nsp+2 > ndim) THEN - inder(1)=inder(1)+1 ! count errors - RETURN ! record dimension too small - END IF - nr=nr+1 ! zero pair - glder(nr)=0.0 - inder(nr)=0 - nr=nr+1 ! nsp and zero - glder(nr)=-REAL(nsp,mps) - inder(nr)=0 - DO i=1,nsp - nr=nr+1 - glder(nr)=dergl(i) ! floating-point - inder(nr)=label(i) ! integer - END DO - RETURN - - ENTRY KILLE ! stop record - nr=0 ! reset - RETURN - - ENTRY ENDLE ! end-of-record - IF(nr > 1) THEN - WRITE(lun) nr+nr,(glder(i),i=1,nr),(inder(i),i=1,nr) - END IF - nr=0 ! reset - RETURN -END SUBROUTINE MILLE diff --git a/millepede/minresDataModule.f90 b/millepede/minresDataModule.f90 deleted file mode 100644 index 125e779735..0000000000 --- a/millepede/minresDataModule.f90 +++ /dev/null @@ -1,28 +0,0 @@ - -!> \file -!! MINRES (data) definitions. - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! File minresDataModule.f90 -! -! Defines real(kind=dp) and a few constants for use in other modules. -! -! 14 Oct 2007: First version implemented after realizing -r8 is not -! a standard compiler option. -! 15 Oct 2007: Temporarily used real(8) everywhere. -! 16 Oct 2007: Found that we need -! use minresDataModule -! at the beginning of modules AND inside interfaces. -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -!> Defines real(kind=dp) and a few constants for use in other modules. -module minresDataModule - use mpdef, only: mpd - - implicit none - - intrinsic :: selected_real_kind - integer, parameter, public :: dp = mpd !selected_real_kind(15) - real(kind=dp), parameter, public :: zero = 0.0_dp, one = 1.0_dp - -end module minresDataModule diff --git a/millepede/minresModule.f90 b/millepede/minresModule.f90 deleted file mode 100644 index 429f91399d..0000000000 --- a/millepede/minresModule.f90 +++ /dev/null @@ -1,660 +0,0 @@ -!> \file -!! MINRES algorithm. - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! File minresModule.f90 -! -!> MINRES solves symmetric systems Ax = b or min ||Ax - b||_2, -!! where the matrix A may be indefinite and/or singular. -!! \verbatim -!! -!! The software for MINRES (f90 version) is provided by SOL, Stanford University -!! under the terms of the OSI Common Public License (CPL): -!! http://www.opensource.org/licenses/cpl1.0.php -!! -!! Contributors: -!! Chris Paige -!! Sou-Cheng Choi -!! -!! Michael Saunders -!! Systems Optimization Laboratory (SOL) -!! Stanford University -!! Stanford, CA 94305-4026, USA -!! (650)723-1875 -!! -!! 09 Oct 2007: F90 version constructed from the F77 version. -!! Initially used compiler option -r8, but this is nonstandard. -!! 15 Oct 2007: Test on Arnorm = ||Ar|| added to recognize singular systems. -!! 15 Oct 2007: Temporarily used real(8) everywhere. -!! 16 Oct 2007: Use minresDataModule to define dp = selected_real_kind(15). -!! We need "use minresDataModule" -!! at the beginning of modules AND inside interfaces. -!! -!! g95 compiles successfully with the following options: -!! g95 -c -g -O0 -pedantic -Wall -Wextra -fbounds-check -ftrace=full minresModule.f90 -!! -!! \endverbatim -!!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -module minresModule - - use minresDataModule, only : dp - - implicit none - public :: MINRES - -contains - - !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - !> Solution of linear equation system. - !! - !! \verbatim - !!------------------------------------------------------------------- - !! - !! MINRES is designed to solve the system of linear equations - !! - !! Ax = b - !! - !! or the least-squares problem - !! - !! min ||Ax - b||_2, - !! - !! where A is an n by n symmetric matrix and b is a given vector. - !! The matrix A may be indefinite and/or singular. - !! - !! 1. If A is known to be positive definite, the Conjugate Gradient - !! Method might be preferred, since it requires the same number - !! of iterations as MINRES but less work per iteration. - !! - !! 2. If A is indefinite but Ax = b is known to have a solution - !! (e.g. if A is nonsingular), SYMMLQ might be preferred, - !! since it requires the same number of iterations as MINRES - !! but slightly less work per iteration. - !! - !! The matrix A is intended to be large and sparse. It is accessed - !! by means of a subroutine call of the form - !! SYMMLQ development: - !! - !! call Aprod ( n, x, y ) - !! - !! which must return the product y = Ax for any given vector x. - !! - !! - !! More generally, MINRES is designed to solve the system - !! - !! (A - shift*I) x = b - !! or - !! min ||(A - shift*I) x - b||_2, - !! - !! where shift is a specified scalar value. Again, the matrix - !! (A - shift*I) may be indefinite and/or singular. - !! The work per iteration is very slightly less if shift = 0. - !! - !! Note: If shift is an approximate eigenvalue of A - !! and b is an approximate eigenvector, x might prove to be - !! a better approximate eigenvector, as in the methods of - !! inverse iteration and/or Rayleigh-quotient iteration. - !! However, we're not yet sure on that -- it may be better to use SYMMLQ. - !! - !! A further option is that of preconditioning, which may reduce - !! the number of iterations required. If M = C C' is a positive - !! definite matrix that is known to approximate (A - shift*I) - !! in some sense, and if systems of the form My = x can be - !! solved efficiently, the parameters precon and Msolve may be - !! used (see below). When precon = .true., MINRES will - !! implicitly solve the system of equations - !! - !! P (A - shift*I) P' xbar = P b, - !! - !! i.e. Abar xbar = bbar - !! where P = C**(-1), - !! Abar = P (A - shift*I) P', - !! bbar = P b, - !! - !! and return the solution x = P' xbar. - !! The associated residual is rbar = bbar - Abar xbar - !! = P (b - (A - shift*I)x) - !! = P r. - !! - !! In the discussion below, eps refers to the machine precision. - !! - !! Parameters - !! ---------- - !! - !! n input The dimension of the matrix A. - !! b(n) input The rhs vector b. - !! x(n) output Returns the computed solution x. - !! - !! Aprod external A subroutine defining the matrix A. - !! call Aprod ( n, x, y ) - !! must return the product y = Ax - !! without altering the vector x. - !! - !! Msolve external An optional subroutine defining a - !! preconditioning matrix M, which should - !! approximate (A - shift*I) in some sense. - !! M must be positive definite. - !! - !! call Msolve( n, x, y ) - !! - !! must solve the linear system My = x - !! without altering the vector x. - !! - !! In general, M should be chosen so that Abar has - !! clustered eigenvalues. For example, - !! if A is positive definite, Abar would ideally - !! be close to a multiple of I. - !! If A or A - shift*I is indefinite, Abar might - !! be close to a multiple of diag( I -I ). - !! - !! checkA input If checkA = .true., an extra call of Aprod will - !! be used to check if A is symmetric. Also, - !! if precon = .true., an extra call of Msolve - !! will be used to check if M is symmetric. - !! - !! precon input If precon = .true., preconditioning will - !! be invoked. Otherwise, subroutine Msolve - !! will not be referenced; in this case the - !! actual parameter corresponding to Msolve may - !! be the same as that corresponding to Aprod. - !! - !! shift input Should be zero if the system Ax = b is to be - !! solved. Otherwise, it could be an - !! approximation to an eigenvalue of A, such as - !! the Rayleigh quotient b'Ab / (b'b) - !! corresponding to the vector b. - !! If b is sufficiently like an eigenvector - !! corresponding to an eigenvalue near shift, - !! then the computed x may have very large - !! components. When normalized, x may be - !! closer to an eigenvector than b. - !! - !! nout input A file number. - !! If nout > 0, a summary of the iterations - !! will be printed on unit nout. - !! - !! itnlim input An upper limit on the number of iterations. - !! - !! rtol input A user-specified tolerance. MINRES terminates - !! if it appears that norm(rbar) is smaller than - !! rtol * norm(Abar) * norm(xbar), - !! where rbar is the transformed residual vector, - !! rbar = bbar - Abar xbar. - !! - !! If shift = 0 and precon = .false., MINRES - !! terminates if norm(b - A*x) is smaller than - !! rtol * norm(A) * norm(x). - !! - !! istop output An integer giving the reason for termination... - !! - !! -1 beta2 = 0 in the Lanczos iteration; i.e. the - !! second Lanczos vector is zero. This means the - !! rhs is very special. - !! If there is no preconditioner, b is an - !! eigenvector of A. - !! Otherwise (if precon is true), let My = b. - !! If shift is zero, y is a solution of the - !! generalized eigenvalue problem Ay = lambda My, - !! with lambda = alpha1 from the Lanczos vectors. - !! - !! In general, (A - shift*I)x = b - !! has the solution x = (1/alpha1) y - !! where My = b. - !! - !! 0 b = 0, so the exact solution is x = 0. - !! No iterations were performed. - !! - !! 1 Norm(rbar) appears to be less than - !! the value rtol * norm(Abar) * norm(xbar). - !! The solution in x should be acceptable. - !! - !! 2 Norm(rbar) appears to be less than - !! the value eps * norm(Abar) * norm(xbar). - !! This means that the residual is as small as - !! seems reasonable on this machine. - !! - !! 3 Norm(Abar) * norm(xbar) exceeds norm(b)/eps, - !! which should indicate that x has essentially - !! converged to an eigenvector of A - !! corresponding to the eigenvalue shift. - !! - !! 4 Acond (see below) has exceeded 0.1/eps, so - !! the matrix Abar must be very ill-conditioned. - !! x may not contain an acceptable solution. - !! - !! 5 The iteration limit was reached before any of - !! the previous criteria were satisfied. - !! - !! 6 The matrix defined by Aprod does not appear - !! to be symmetric. - !! For certain vectors y = Av and r = Ay, the - !! products y'y and r'v differ significantly. - !! - !! 7 The matrix defined by Msolve does not appear - !! to be symmetric. - !! For vectors satisfying My = v and Mr = y, the - !! products y'y and r'v differ significantly. - !! - !! 8 An inner product of the form x' M**(-1) x - !! was not positive, so the preconditioning matrix - !! M does not appear to be positive definite. - !! - !! If istop >= 5, the final x may not be an - !! acceptable solution. - !! - !! itn output The number of iterations performed. - !! - !! Anorm output An estimate of the norm of the matrix operator - !! Abar = P (A - shift*I) P', where P = C**(-1). - !! - !! Acond output An estimate of the condition of Abar above. - !! This will usually be a substantial - !! under-estimate of the true condition. - !! - !! rnorm output An estimate of the norm of the final - !! transformed residual vector, - !! P (b - (A - shift*I) x). - !! - !! ynorm output An estimate of the norm of xbar. - !! This is sqrt( x'Mx ). If precon is false, - !! ynorm is an estimate of norm(x). - !!------------------------------------------------------------------- - !! MINRES is an implementation of the algorithm described in - !! the following reference: - !! - !! C. C. Paige and M. A. Saunders (1975), - !! Solution of sparse indefinite systems of linear equations, - !! SIAM J. Numer. Anal. 12(4), pp. 617-629. - !!------------------------------------------------------------------- - !! - !! - !! MINRES development: - !! 1972: First version, similar to original SYMMLQ. - !! Later lost @#%*!! - !! Oct 1995: Tried to reconstruct MINRES from - !! 1995 version of SYMMLQ. - !! 30 May 1999: Need to make it more like LSQR. - !! In middle of major overhaul. - !! 19 Jul 2003: Next attempt to reconstruct MINRES. - !! Seems to need two vectors more than SYMMLQ. (w1, w2) - !! Lanczos is now at the top of the loop, - !! so the operator Aprod is called in just one place - !! (not counting the initial check for symmetry). - !! 22 Jul 2003: Success at last. Preconditioning also works. - !! minres.f added to http://www.stanford.edu/group/SOL/. - !! - !! 16 Oct 2007: Added a stopping rule for singular systems, - !! as derived in Sou-Cheng Choi's PhD thesis. - !! Note that ||Ar|| small => r is a null vector for A. - !! Subroutine minrestest2 in minresTestModule.f90 - !! tests this option. (NB: Not yet working.) - !!------------------------------------------------------------------- - !! \endverbatim - subroutine MINRES( n, Aprod, Msolve, b, shift, checkA, precon, & - x, itnlim, nout, rtol, & - istop, itn, Anorm, Acond, rnorm, Arnorm, ynorm ) - - integer, intent(in) :: n, itnlim, nout - logical, intent(in) :: checkA, precon - real(dp), intent(in) :: b(n) - real(dp), intent(in) :: shift, rtol - real(dp), intent(out) :: x(n) - integer, intent(out) :: istop, itn - real(dp), intent(out) :: Anorm, Acond, rnorm, Arnorm, ynorm - - interface - subroutine Aprod (n,x,y) ! y := A*x - use minresDataModule - integer, intent(in) :: n - real(dp), intent(in) :: x(n) - real(dp), intent(out) :: y(n) - end subroutine Aprod - - subroutine Msolve(n,x,y) ! Solve M*y = x - use minresDataModule - integer, intent(in) :: n - real(dp), intent(in) :: x(n) - real(dp), intent(out) :: y(n) - end subroutine Msolve - end interface - -! Local arrays and variables - real(dp) :: r1(n), r2(n), v(n), w(n), w1(n), w2(n), y(n) - real(dp) :: alfa , beta , beta1 , cs , & - dbar , delta , denom , diag , & - eps , epsa , epsln , epsr , epsx , & - gamma , gbar , gmax , gmin , & - oldb , oldeps, qrnorm, phi , phibar, & - rhs1 , rhs2 , rnorml, rootl , & - Arnorml, relArnorml, & - s , sn , t , tnorm2, ynorm2, z - integer :: i - logical :: debug, prnt - - ! Local constants - real(dp), parameter :: zero = 0.0, one = 1.0 - real(dp), parameter :: ten = 10.0 - character(len=*), parameter :: enter = ' Enter MINRES. ' - character(len=*), parameter :: exitt = ' Exit MINRES. ' - character(len=*), parameter :: msg(-1:8) = & - (/ 'beta2 = 0. If M = I, b and x are eigenvectors of A', & ! -1 - 'beta1 = 0. The exact solution is x = 0 ', & ! 0 - 'Requested accuracy achieved, as determined by rtol ', & ! 1 - 'Reasonable accuracy achieved, given eps ', & ! 2 - 'x has converged to an eigenvector ', & ! 3 - 'Acond has exceeded 0.1/eps ', & ! 4 - 'The iteration limit was reached ', & ! 5 - 'Aprod does not define a symmetric matrix ', & ! 6 - 'Msolve does not define a symmetric matrix ', & ! 7 - 'Msolve does not define a pos-def preconditioner ' /) ! 8 - !------------------------------------------------------------------- - - intrinsic :: abs, dot_product, epsilon, min, max, sqrt - - ! Print heading and initialize. - - debug = .false. - eps = epsilon(eps) - if (nout > 0) then - write(nout, 1000) enter, n, checkA, precon, itnlim, rtol, shift - end if - istop = 0 - itn = 0 - Anorm = zero - Acond = zero - rnorm = zero - ynorm = zero - x(1:n) = zero - Arnorml = zero - gmin = zero - gmax = zero - - !------------------------------------------------------------------- - ! Set up y and v for the first Lanczos vector v1. - ! y = beta1 P' v1, where P = C**(-1). - ! v is really P' v1. - !------------------------------------------------------------------- - y = b - r1 = b - if ( precon ) call Msolve( n, b, y ) - beta1 = dot_product(b,y) - - if (beta1 < zero) then ! M must be indefinite. - istop = 8 - go to 900 - end if - - if (beta1 == zero) then ! b = 0 exactly. Stop with x = 0. - istop = 0 - go to 900 - end if - - beta1 = sqrt( beta1 ) ! Normalize y to get v1 later. - - !------------------------------------------------------------------- - ! See if Msolve is symmetric. - !------------------------------------------------------------------- - if (checkA .and. precon) then - call Msolve( n, y, r2 ) - s = dot_product(y ,y ) - t = dot_product(r1,r2) - z = abs(s - t) - epsa = (s + eps) * eps**0.33333 - if (z > epsa) then - istop = 7 - go to 900 - end if - end if - - !------------------------------------------------------------------- - ! See if Aprod is symmetric. Initialize Arnorm. - !------------------------------------------------------------------- - if (checkA) then - call Aprod ( n, y, w ) - call Aprod ( n, w, r2 ) - s = dot_product(w,w ) - t = dot_product(y,r2) - z = abs(s - t) - epsa = (s + eps) * eps**0.33333 - if (z > epsa) then - istop = 6 - go to 900 - end if - Arnorml = sqrt(s); - else - call Aprod ( n, y, w ) - Arnorml = sqrt( dot_product(w,w) ) - end if - - !------------------------------------------------------------------- - ! Initialize other quantities. - !------------------------------------------------------------------- - oldb = zero - beta = beta1 - dbar = zero - epsln = zero - qrnorm = beta1 - phibar = beta1 - rhs1 = beta1 - rhs2 = zero - tnorm2 = zero - ynorm2 = zero - cs = - one - sn = zero - w(1:n) = zero - w2(1:n)= zero - r2(1:n)= r1 - - if (debug) then - write(*,*) ' ' - write(*,*) 'b ', b - write(*,*) 'beta ', beta - write(*,*) ' ' - end if - - !=================================================================== - ! Main iteration loop. - !=================================================================== - do - itn = itn + 1 ! k = itn = 1 first time through - - !---------------------------------------------------------------- - ! Obtain quantities for the next Lanczos vector vk+1, k = 1, 2,... - ! The general iteration is similar to the case k = 1 with v0 = 0: - ! - ! p1 = Operator * v1 - beta1 * v0, - ! alpha1 = v1'p1, - ! q2 = p2 - alpha1 * v1, - ! beta2^2 = q2'q2, - ! v2 = (1/beta2) q2. - ! - ! Again, y = betak P vk, where P = C**(-1). - ! .... more description needed. - !---------------------------------------------------------------- - s = one / beta ! Normalize previous vector (in y). - v = s*y(1:n) ! v = vk if P = I - - call Aprod ( n, v, y ) - y = y - shift*v ! call daxpy ( n, (- shift), v, 1, y, 1 ) - if (itn >= 2) then - y = y - (beta/oldb)*r1 ! call daxpy ( n, (- beta/oldb), r1, 1, y, 1 ) - end if - - alfa = dot_product(v,y) ! alphak - y = y - (alfa/beta)*r2 ! call daxpy ( n, (- alfa/beta), r2, 1, y, 1 ) - r1 = r2 - r2 = y - if ( precon ) call Msolve( n, r2, y ) - - oldb = beta ! oldb = betak - beta = dot_product(r2,y) ! beta = betak+1^2 - if (beta < zero) then - istop = 6 - go to 900 - end if - - beta = sqrt( beta ) ! beta = betak+1 - tnorm2 = tnorm2 + alfa**2 + oldb**2 + beta**2 - - if (itn == 1) then ! Initialize a few things. - if (beta/beta1 <= ten*eps) then ! beta2 = 0 or ~ 0. - istop = -1 ! Terminate later. - end if - !tnorm2 = alfa**2 - gmax = abs( alfa ) ! alpha1 - gmin = gmax ! alpha1 - end if - - ! Apply previous rotation Qk-1 to get - ! [deltak epslnk+1] = [cs sn][dbark 0 ] - ! [gbar k dbar k+1] [sn -cs][alfak betak+1]. - - oldeps = epsln - delta = cs * dbar + sn * alfa ! delta1 = 0 deltak - gbar = sn * dbar - cs * alfa ! gbar 1 = alfa1 gbar k - epsln = sn * beta ! epsln2 = 0 epslnk+1 - dbar = - cs * beta ! dbar 2 = beta2 dbar k+1 - - ! Compute the next plane rotation Qk - - gamma = sqrt( gbar**2 + beta**2 ) ! gammak - cs = gbar / gamma ! ck - sn = beta / gamma ! sk - phi = cs * phibar ! phik - phibar = sn * phibar ! phibark+1 - - if (debug) then - write(*,*) ' ' - write(*,*) 'v ', v - write(*,*) 'alfa ', alfa - write(*,*) 'beta ', beta - write(*,*) 'gamma', gamma - write(*,*) 'delta', delta - write(*,*) 'gbar ', gbar - write(*,*) 'epsln', epsln - write(*,*) 'dbar ', dbar - write(*,*) 'phi ', phi - write(*,*) 'phiba', phibar - write(*,*) ' ' - end if - - ! Update x. - - denom = one/gamma - - do i = 1, n - w1(i) = w2(i) - w2(i) = w(i) - w(i) = ( v(i) - oldeps*w1(i) - delta*w2(i) ) * denom - x(i) = x(i) + phi * w(i) - end do - - ! Go round again. - - gmax = max( gmax, gamma ) - gmin = min( gmin, gamma ) - z = rhs1 / gamma - ynorm2 = z**2 + ynorm2 - rhs1 = rhs2 - delta * z - rhs2 = - epsln * z - - ! Estimate various norms and test for convergence. - - Anorm = sqrt( tnorm2 ) - ynorm = sqrt( ynorm2 ) - epsa = Anorm * eps - epsx = Anorm * ynorm * eps - epsr = Anorm * ynorm * rtol - diag = gbar - if (diag == zero) diag = epsa - - qrnorm = phibar - rnorml = rnorm - rnorm = qrnorm - rootl = sqrt( gbar**2 +dbar**2 ) ! norm([gbar; dbar]); - Arnorml = rnorml*rootl ! ||A r_{k-1} || - relArnorml = rootl / Anorm; ! ||Ar|| / (||A|| ||r||) - !relArnorml = Arnorml / Anorm; ! ||Ar|| / ||A|| - - ! Estimate cond(A). - ! In this version we look at the diagonals of R in the - ! factorization of the lower Hessenberg matrix, Q * H = R, - ! where H is the tridiagonal matrix from Lanczos with one - ! extra row, beta(k+1) e_k^T. - - Acond = gmax / gmin - - ! See if any of the stopping criteria are satisfied. - ! In rare cases, istop is already -1 from above (Abar = const*I). - - if (istop == 0) then - if (itn >= itnlim ) istop = 5 - if (Acond >= 0.1d+0/eps) istop = 4 - if (epsx >= beta1 ) istop = 3 - ! original - !if (qrnorm <= epsx .or. relArnorml <= epsx) istop = 2 - !if (qrnorm <= epsr .or. relArnorml <= epsr) istop = 1 - ! C. Kleinwort, DESY, 131002 - if (qrnorm <= epsx .or. relArnorml <= eps) istop = 2 - if (qrnorm <= epsr .or. relArnorml <= rtol) istop = 1 - end if - - - ! See if it is time to print something. - - if (nout > 0) then - prnt = .false. - if (n <= 40 ) prnt = .true. - if (itn <= 10 ) prnt = .true. - if (itn >= itnlim - 10) prnt = .true. - if (mod(itn,10) == 0) prnt = .true. - if (qrnorm <= ten * epsx) prnt = .true. - if (qrnorm <= ten * epsr) prnt = .true. - if (relArnorml<= ten*epsx) prnt = .true. - if (relArnorml<= ten*epsr) prnt = .true. - if (Acond >= 1.0d-2/eps ) prnt = .true. - if (istop /= 0 ) prnt = .true. - - if ( prnt ) then - if ( itn == 1) write(nout, 1200) - write(nout, 1300) itn, x(1), qrnorm, Anorm, Acond - if (mod(itn,10) == 0) write(nout, 1500) - end if - end if - if (istop /= 0) exit - - end do - !=================================================================== - ! End of iteration loop. - !=================================================================== - - ! Display final status. - -900 Arnorm = Arnorml - if (nout > 0) then - write(nout, 2000) exitt, istop, itn, & - exitt, Anorm, Acond, & - exitt, rnorm, ynorm, Arnorm - write(nout, 3000) exitt, msg(istop) - end if - - return - - 1000 format(// 1p, a, 5x, 'Solution of symmetric Ax = b' & - / ' n =', i7, 5x, 'checkA =', l4, 12x, & - 'precon =', l4 & - / ' itnlim =', i7, 5x, 'rtol =', e11.2, 5x, & - 'shift =', e23.14) - 1200 format(// 5x, 'itn', 8x, 'x(1)', 10x, & - 'norm(r)', 3x, 'norm(A)', 3X, 'cond(A)') - 1300 format(1p, i8, e19.10, 3e10.2) - 1500 format(1x) - 2000 format(/ 1p, a, 5x, 'istop =', i3, 14x, 'itn =', i8 & - / a, 5x, 'Anorm =', e12.4, 5x, 'Acond =', e12.4 & - / a, 5x, 'rnorm =', e12.4, 5x, 'ynorm =', e12.4, 5x, 'Arnorml =', e12.4) - 3000 format( a, 5x, a ) - - end subroutine MINRES - -end module minresModule diff --git a/millepede/minresqlpBlasModule.f90 b/millepede/minresqlpBlasModule.f90 deleted file mode 100644 index 02946e87ae..0000000000 --- a/millepede/minresqlpBlasModule.f90 +++ /dev/null @@ -1,219 +0,0 @@ -!> \file -!! MINRES-QLP BLAS subroutines. - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! File minresqlpBlasModule.f90 -! -! This file contains the following BLAS subroutines -! ddot, dnrm2 -! required by subroutine MINRESQLP. -! -! Contributors: -! Sou-Cheng Choi -! Computation Institute (CI) -! University of Chicago -! Chicago, IL 60637, USA -! -! Michael Saunders -! Systems Optimization Laboratory (SOL) -! Stanford University -! Stanford, CA 94305-4026, USA -! -! History: -! 24 Sep 2007: All parameters declared with correct intent -! to avoid compiler warnings. -! 24 Oct 2007: Use real(8) instead of double precision or -r8. -! 24 May 2011: Use a module to package the BLAS subroutines. Use real(dp) -! instead of real(8), where dp is a constant defined in -! minresqlpDataModule and used in other program units. -! 12 Jul 2011: Created complex version zminresqlpBlasModule.f90 -! from real version minresqlpBlasModule.f90. -! 03 Aug 2013: dp constants 0.d0 and 1.d0 defined with _dp. -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -module minresqlpBlasModule - - use minresqlpDataModule, only : dp, ip, zero, one - implicit none - - public :: ddot, dnrm2 - -contains - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!> DDOT forms the dot product of two vectors. -! -! Discussion: -! This routine uses double precision real arithmetic. -! This routine uses unrolled loops for increments equal to one. -! -! Modified: -! 16 May 2005 -! -! Author: -! Jack Dongarra -! Fortran90 translation by John Burkardt. -! -! Reference: -! Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart, -! LINPACK User's Guide, -! SIAM, 1979, -! ISBN13: 978-0-898711-72-1, -! LC: QA214.L56. -! -! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, -! Algorithm 539, -! Basic Linear Algebra Subprograms for Fortran Usage, -! ACM Transactions on Mathematical Software, -! Volume 5, Number 3, September 1979, pages 308-323. -! -! Parameters: -! -! Input, integer N, the number of entries in the vectors. -! -! Input, real ( kind = dp ) DX(*), the first vector. -! -! Input, integer INCX, the increment between successive entries in DX. -! -! Input, real ( kind = dp ) DY(*), the second vector. -! -! Input, integer INCY, the increment between successive entries in DY. -! -! Output, real ( kind = dp ) DDOT, the sum of the product of the -! corresponding entries of DX and DY. - - real(dp) function ddot(n,dx,incx,dy,incy) - - implicit none - integer(ip), intent(in) :: n,incx,incy - real(dp), intent(in) :: dx(*),dy(*) - - real(dp) :: dtemp - integer(ip) :: i,ix,iy,m - - ddot = zero - dtemp = zero - if ( n <= 0 ) then - return - end if - -! Code for unequal increments or equal increments -! not equal to 1. - - if ( incx /= 1 .or. incy /= 1 ) then - - if ( 0 <= incx ) then - ix = 1 - else - ix = ( - n + 1 ) * incx + 1 - end if - - if ( 0 <= incy ) then - iy = 1 - else - iy = ( - n + 1 ) * incy + 1 - end if - - do i = 1, n - dtemp = dtemp + dx(ix) * dy(iy) - ix = ix + incx - iy = iy + incy - end do - -! Code for both increments equal to 1. - - else - - m = mod ( n, 5 ) - - do i = 1, m - dtemp = dtemp + dx(i) * dy(i) - end do - - do i = m+1, n, 5 - dtemp = dtemp + dx(i)*dy(i) + dx(i+1)*dy(i+1) + dx(i+2)*dy(i+2) & - + dx(i+3)*dy(i+3) + dx(i+4)*dy(i+4) - end do - - end if - - ddot = dtemp - return -end function ddot - -!***************************************************************************** -! -!> DNRM2 returns the euclidean norm of a vector. -! -! Discussion: -! This routine uses real(dp) real arithmetic. -! DNRM2 ( X ) = sqrt ( X' * X ) -! -! Modified: -! 16 May 2005 -! -! Author: -! Sven Hammarling -! Fortran90 translation by John Burkardt. -! -! Reference: -! Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart, -! LINPACK User's Guide, -! SIAM, 1979, -! ISBN13: 978-0-898711-72-1, -! LC: QA214.L56. -! -! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, -! Algorithm 539, -! Basic Linear Algebra Subprograms for Fortran Usage, -! ACM Transactions on Mathematical Software, -! Volume 5, Number 3, September 1979, pages 308-323. -! -! Parameters: -! -! Input, integer N, the number of entries in the vector. -! -! Input, real ( kind = dp ) X(*), the vector whose norm is to be computed. -! -! Input, integer INCX, the increment between successive entries of X. -! -! Output, real ( kind = dp ) DNRM2, the Euclidean norm of X. - - real(dp) function dnrm2 ( n, x, incx ) - - implicit none - integer(ip), intent(in) :: n,incx - real(dp), intent(in) :: x(*) - - integer(ip) :: ix - real(dp) :: ssq,absxi,norm,scale - - if ( n < 1 .or. incx < 1 ) then - norm = zero - else if ( n == 1 ) then - norm = abs ( x(1) ) - else - scale = zero - ssq = one - - do ix = 1, 1 + ( n - 1 )*incx, incx - if ( x(ix) /= zero ) then - absxi = abs ( x(ix) ) - if ( scale < absxi ) then - ssq = 1_dp + ssq * ( scale / absxi )**2 - scale = absxi - else - ssq = ssq + ( absxi / scale )**2 - end if - end if - end do - norm = scale * sqrt ( ssq ) - end if - - dnrm2 = norm - return -end function dnrm2 - -end module minresqlpBlasModule diff --git a/millepede/minresqlpDataModule.f90 b/millepede/minresqlpDataModule.f90 deleted file mode 100644 index f33b493ff2..0000000000 --- a/millepede/minresqlpDataModule.f90 +++ /dev/null @@ -1,57 +0,0 @@ -!> \file -!! MINRES-QLP (data) definitions. - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! File minresqlpDataModule.f90 -! -!> Defines precision and range in real(kind=dp) and integer(kind=ip) for -!! portability and a few constants for use in other modules. -! -! -! Authors: -! Sou-Cheng Choi -! Computation Institute (CI) -! University of Chicago -! Chicago, IL 60637, USA -! -! Michael Saunders -! Systems Optimization Laboratory (SOL) -! Stanford University -! Stanford, CA 94305-4026, USA -! -! History: -! 14 Oct 2007: First version implemented after realizing -r8 is not -! a standard compiler option. -! 15 Oct 2007: Temporarily used real(8) everywhere. -! 16 Oct 2007: Found that we need -! use minresqlpDataModule -! at the beginning of modules AND inside interfaces. -! 20 Aug 2012: (1) Added single real kind 'sp' and integer kind 'ip'. -! (2) Added smallest and largest real positive 'realmin' -! and 'realmax'. -! (3) Added single precision kind 'sp'. -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -module minresqlpDataModule - use mpdef, only: mpi, mps, mpd - - implicit none - - intrinsic :: selected_real_kind, selected_int_kind, tiny, huge - - ! The following reals are provided for portability. Do not use 'DOUBLE PRECISION'. - integer, parameter, public :: dp = mpd !selected_real_kind(15,307) ! 64-bit real, default - integer, parameter, public :: sp = mps !selected_real_kind(6,37) ! 32-bit real - !integer, parameter, public :: qp = selected_real_kind(33,4931) !128-bit real - - integer, parameter, public :: ip = mpi !selected_int_kind(9) ! R: (-10^R, 10^R) - - real(dp), parameter, public :: zero = 0.0_dp, one = 1.0_dp, eps = epsilon(zero) - real(dp), parameter, public :: realmin = tiny(one), realmax = huge(one) - - integer, parameter, public :: prcsn = precision(zero) ! first argument of selected_real_kind - - ! WARN: turning on debug could significantly slow down the program due to file output - logical, public :: debug = .false. - logical, public :: testSymortho = .true., testMtx = .true. -end module minresqlpDataModule diff --git a/millepede/minresqlpModule.f90 b/millepede/minresqlpModule.f90 deleted file mode 100644 index f512b756a6..0000000000 --- a/millepede/minresqlpModule.f90 +++ /dev/null @@ -1,1382 +0,0 @@ -!> \file -!! MINRES-QLP algorithm. - - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! File minresqlpModule.f90 -! -!> MINRESQLP solves symmetric systems Ax = b or min ||Ax - b||_2, -!! where the matrix A may be indefinite and/or singular. -!! "A" is really (A - shift*I), where shift is an input real scalar. -!! -!! \verbatim -!! 09 Sep 2013: Version 27 -!!------------------------------------------------------------------- -!! -!! The software for MINRES-QLP is provided by SOL, Stanford University -!! under the terms of the OSI Common Public License (CPL) -!! http://www.opensource.org/licenses/cpl1.0.php -!! or the BSD License -!! http://www.opensource.org/licenses/bsd-license.php -!! -!!------------------------------------------------------------------- -!! -!! Authors: -!! Sou-Cheng Choi -!! Computation Institute (CI) -!! University of Chicago -!! Chicago, IL 60637, USA -!! -!! Michael Saunders -!! Systems Optimization Laboratory (SOL) -!! Stanford University -!! Stanford, CA 94305-4026, USA -!! -!! Contributor: -!! Christopher Paige -!! -!! See also: Makefile -!! \endverbatim -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -module minresqlpModule - - use minresqlpDataModule, only : dp, ip, one, zero, eps, realmin, prcsn, debug - use minresqlpBlasModule, only : dnrm2 - - implicit none - - private ! sets default for module - public :: MINRESQLP, SYMORTHO - -contains - - !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - !> Solution of linear equation system or least squares problem. - !! - !! \verbatim - !!------------------------------------------------------------------ - !! - !! MINRESQLP is designed to solve the system of linear equations - !! - !! Ax = b - !! - !! or the least-squares problem - !! - !! min || Ax - b ||_2, - !! - !! where A is an n by n symmetric matrix and b is a given vector. - !! The matrix A may be indefinite and/or singular. - !! - !! 1. If A is known to be positive definite, the Conjugate Gradient - !! Method might be preferred, since it requires roughly the same - !! number of iterations as MINRESQLP but less work per iteration. - !! But if a low-accuracy solution is adequate, MINRESQLP will - !! terminate sooner. - !! - !! 2. If A is indefinite but Ax = b is known to have a solution - !! (e.g. if A is nonsingular), SYMMLQ might be preferred, - !! since it requires roughly the same number of iterations as - !! MINRESQLP but slightly less work per iteration. - !! - !! 3. If A is indefinite and well-conditioned, and Ax = b has a - !! solution, i.e., it is not a least-squares problem, MINRES might - !! be preferred as it requires the same number of iterations as - !! MINRESQLP but slightly less work per iteration. - !! - !! The matrix A is intended to be large and sparse. It is accessed - !! by means of a subroutine call of the form - !! - !! call Aprod ( n, x, y ) - !! - !! which must return the product y = Ax for any given vector x. - !! - !! - !! More generally, MINRESQLP is designed to solve the system - !! - !! (A - shift*I) x = b - !! or - !! min || (A - shift*I) x - b ||_2, - !! - !! where shift is a specified real scalar. Again, the matrix - !! (A - shift*I) may be indefinite and/or singular. - !! The work per iteration is very slightly less if shift = 0. - !! - !! Note: If shift is an approximate eigenvalue of A - !! and b is an approximate eigenvector, x might prove to be - !! a better approximate eigenvector, as in the methods of - !! inverse iteration and/or Rayleigh-quotient iteration. - !! However, we are not yet sure on that -- it may be better - !! to use SYMMLQ. - !! - !! In this documentation, ' denotes the transpose of - !! a vector or a matrix. - !! - !! A further option is that of preconditioning, which may reduce - !! the number of iterations required. If M = C C' is a positive - !! definite matrix that is known to approximate (A - shift*I) - !! in some sense, and if systems of the form My = x can be - !! solved efficiently, the parameter Msolve may be used (see below). - !! When an external procedure Msolve is supplied, MINRESQLP will - !! implicitly solve the system of equations - !! - !! P (A - shift*I) P' xbar = P b, - !! - !! i.e. Abar xbar = bbar - !! where P = C**(-1), - !! Abar = P (A - shift*I) P', - !! bbar = P b, - !! - !! and return the solution x = P' xbar. - !! The associated residual is rbar = bbar - Abar xbar - !! = P (b - (A - shift*I)x) - !! = P r. - !! - !! In the discussion below, eps refers to the machine precision. - !! eps is computed by MINRESQLP. A typical value is eps = 2.22d-16 - !! for IEEE double-precision arithmetic. - !! - !! Parameters - !! ---------- - !! Some inputs are optional, with default values described below. - !! Mandatory inputs are n, Aprod, and b. - !! All outputs other than x are optional. - !! - !! n input The dimension of the matrix or operator A. - !! - !! b(n) input The rhs vector b. - !! - !! x(n) output Returns the computed solution x. - !! - !! Aprod external A subroutine defining the matrix A. - !! For a given vector x, the statement - !! - !! call Aprod ( n, x, y ) - !! - !! must return the product y = Ax - !! without altering the vector x. - !! An extra call of Aprod is - !! used to check if A is symmetric. - !! - !! Msolve external An optional subroutine defining a - !! preconditioning matrix M, which should - !! approximate (A - shift*I) in some sense. - !! M must be positive definite. - !! For a given vector x, the statement - !! - !! call Msolve( n, x, y ) - !! - !! must solve the linear system My = x - !! without altering the vector x. - !! - !! In general, M should be chosen so that Abar has - !! clustered eigenvalues. For example, - !! if A is positive definite, Abar would ideally - !! be close to a multiple of I. - !! If A or A - shift*I is indefinite, Abar might - !! be close to a multiple of diag( I -I ). - !! - !! shift input Should be zero if the system Ax = b is to be - !! solved. Otherwise, it could be an - !! approximation to an eigenvalue of A, such as - !! the Rayleigh quotient b'Ab / (b'b) - !! corresponding to the vector b. - !! If b is sufficiently like an eigenvector - !! corresponding to an eigenvalue near shift, - !! then the computed x may have very large - !! components. When normalized, x may be - !! closer to an eigenvector than b. Default to 0. - !! - !! nout input A file number. The calling program must open a file - !! for output using for example: - !! open(nout, file='MINRESQLP.txt', status='unknown') - !! If nout > 0, a summary of the iterations - !! will be printed on unit nout. If nout is absent or - !! the file associated with nout is not opened properly, - !! results will be written to 'MINRESQLP_tmp.txt'. - !! (Avoid 0, 5, 6 because by convention stderr=0, - !! stdin=5, stdout=6.) - !! - !! itnlim input An upper limit on the number of iterations. Default to 4n. - !! - !! rtol input A user-specified tolerance. MINRESQLP terminates - !! if it appears that norm(rbar) is smaller than - !! rtol*[norm(Abar)*norm(xbar) + norm(b)], - !! where rbar = bbar - Abar xbar, - !! or that norm(Abar*rbar) is smaller than - !! rtol*norm(Abar)*norm(rbar). - !! - !! If shift = 0 and Msolve is absent, MINRESQLP - !! terminates if norm(r) is smaller than - !! rtol*[norm(A)*norm(x) + norm(b)], - !! where r = b - Ax, - !! or if norm(A*r) is smaller than - !! rtol*norm(A)*norm(r). - !! - !! Default to machine precision. - !! - !! istop output An integer giving the reason for termination... - !! 0 Initial value of istop. - !! - !! 1 beta_{k+1} < eps. - !! Iteration k is the final Lanczos step. - !! - !! 2 beta2 = 0 in the Lanczos iteration; i.e. the - !! second Lanczos vector is zero. This means the - !! rhs is very special. - !! - !! If there is no preconditioner, b is an - !! eigenvector of Abar. Also, x = (1/alpha1) b - !! is a solution of Abar x = b. - !! - !! Otherwise (if Msolve is present), let My = b. - !! If shift is zero, y is a solution of the - !! generalized eigenvalue problem Ay = lambda My, - !! with lambda = alpha1 from the Lanczos vectors. - !! - !! In general, (A - shift*I)x = b - !! has the solution x = (1/alpha1) y - !! where My = b. - !! - !! 3 b = 0, so the exact solution is x = 0. - !! No iterations were performed. - !! - !! 4 Norm(rbar) appears to be less than - !! the value rtol * [ norm(Abar) * norm(xbar) + norm(b) ]. - !! The solution in x should be an acceptable - !! solution of Abar x = b. - !! - !! 5 Norm(rbar) appears to be less than - !! the value eps * norm(Abar) * norm(xbar). - !! This means that the solution is as accurate as - !! seems reasonable on this machine. - !! - !! 6 Norm(Abar rbar) appears to be less than - !! the value rtol * norm(Abar) * norm(rbar). - !! The solution in x should be an acceptable - !! least-squares solution. - !! - !! 7 Norm(Abar rbar) appears to be less than - !! the value eps * norm(Abar) * norm(rbar). - !! This means that the least-squares solution is as - !! accurate as seems reasonable on this machine. - !! - !! 8 The iteration limit was reached before convergence. - !! - !! 9 The matrix defined by Aprod does not appear - !! to be symmetric. - !! For certain vectors y = Av and r = Ay, the - !! products y'y and r'v differ significantly. - !! - !! 10 The matrix defined by Msolve does not appear - !! to be symmetric. - !! For vectors satisfying My = v and Mr = y, the - !! products y'y and r'v differ significantly. - !! - !! 11 An inner product of the form x' M**(-1) x - !! was not positive, so the preconditioning matrix - !! M does not appear to be positive definite. - !! - !! 12 xnorm has exceeded maxxnorm or will exceed it - !! next iteration. - !! - !! 13 Acond (see below) has exceeded Acondlim or 0.1/eps, - !! so the matrix Abar must be very ill-conditioned. - !! - !! 14 | gamma_k | < eps. - !! This is very likely a least-squares problem but - !! x may not contain an acceptable solution yet. - !! - !! 15 norm(Abar x) < rtol * norm(Abar) * norm(x). - !! If disable = .true., then a null vector will be - !! obtained, given rtol. - !! - !! If istop >= 7, the final x may not be an - !! acceptable solution. - !! - !! itn output The number of iterations performed. - !! - !! Anorm output An estimate of the norm of the matrix operator - !! Abar = P (A - shift*I) P', where P = C**(-1). - !! - !! Acond output An estimate of the condition of Abar above. - !! This will usually be a substantial - !! under-estimate of the true condition. - !! - !! rnorm output An estimate of the norm of the final - !! transformed residual vector, - !! P (b - (A - shift*I) x). - !! - !! xnorm output An estimate of the norm of xbar. - !! This is sqrt( x'Mx ). If Msolve is absent, - !! xnorm is an estimate of norm(x). - !! - !! maxxnorm input An upper bound on norm(x). Default value is 1e7. - !! - !! trancond input If trancond > 1, a switch is made from MINRES - !! iterations to MINRES-QLP iterations when - !! Acond > trancond. - !! If trancond = 1, all iterations are MINRES-QLP - !! iterations. - !! If trancond = Acondlim, all iterations are - !! conventional MINRES iterations (which are - !! slightly cheaper). - !! Default to 1e7. - !! - !! Acondlim input An upper bound on Acond. Default value is 1e15. - !! - !! disable input All stopping conditions are disabled except - !! norm(Ax) / norm(x) < tol. Default to .false.. - !! - !!------------------------------------------------------------------ - !! - !! MINRESQLP is an implementation of the algorithm described in - !! the following references: - !! - !! Sou-Cheng Choi, - !! Iterative Methods for Singular Linear Equations and Least- - !! Squares Problems, PhD dissertation, ICME, Stanford University, - !! 2006. - !! - !! Sou-Cheng Choi, Christopher Paige, and Michael Saunders, - !! MINRES-QLP: A Krylov subspace method for indefinite or - !! singular symmetric systems, SIAM Journal of Scientific - !! Computing 33:4 (2011) 1810-1836. - !! - !! Sou-Cheng Choi and Michael Saunders, - !! ALGORITHM & DOCUMENTATION: MINRES-QLP for singular Symmetric and Hermitian - !! linear equations and least-squares problems, Technical Report, - !! ANL/MCS-P3027-0812, Computation Institute, - !! University of Chicago/Argonne National Laboratory, 2012. - !! - !! Sou-Cheng Choi and Michael Saunders, - !! ALGORITHM xxx: MINRES-QLP for singular Symmetric and Hermitian - !! linear equations and least-squares problems, - !! ACM Transactions on Mathematical Software, to appear, 2013. - !! - !! FORTRAN 90 and MATLAB implementations are - !! downloadable from - !! http://www.stanford.edu/group/SOL/software.html - !! http://home.uchicago.edu/sctchoi/ - !! - !!------------------------------------------------------------------ - !! - !! MINRESQLP development: - !! 14 Dec 2006: Sou-Cheng's thesis completed. - !! MINRESQLP includes a stopping rule for singular - !! systems (using an estimate of ||Ar||) and very many - !! other things(!). - !! Note that ||Ar|| small => r is a null vector for A. - !! 09 Oct 2007: F90 version constructed from the F77 version. - !! Initially used compiler option -r8, but this is - !! nonstandard. - !! 15 Oct 2007: Test on Arnorm = ||Ar|| added to recognize - !! singular systems. - !! 15 Oct 2007: Temporarily used real(8) everywhere. - !! 16 Oct 2007: Use minresqlpDataModule to define - !! dp = selected_real_kind(15). - !! We need "use minresqlpDataModule" at the - !! beginning of modules AND inside interfaces. - !! 06 Jun 2010: Added comments. - !! 12 Jul 2011: Created complex version zminresqlpModule.f90 - !! from real version minresqlpModule.f90. - !! 23 Aug 2011: (1) Tim Hopkins ran version 17 on the NAG Fortran compiler - !! We removed half a dozen unused variables in MINRESQLP - !! and also local var sgn_a and sgn_b in SMMORTHO, - !! as they result in division by zero for inputs a=b=0. - !! (2) Version 18 was submitted to ACM TOMS for review. - !! 20 Aug 2012: Version 19: - !! (1) Added optional inputs and outputs, and - !! default values for optional inputs. - !! (2) Removed inputs 'checkA' and 'precon'. - !! (3) Changed slightly the order of parameters in the - !! MINRESQLP API. - !! (4) Updated documentation. - !! (5) Fixed a minor bug in printing x(1) in iteration - !! log during MINRES mode. - !! (6) Made sure MINRESQLP is portable in both single - !! and double precison. - !! (7) Fixed a bug to ensure the 2x2 Hermitian reflectors - !! are orthonormal. Make output c real. - !! 24 Apr 2013: istop = 12 now means xnorm just exceeded maxxnorm. - !! 28 Jun 2013: likeLS introduced to terminate with big xnorm - !! only if the problem seems to be singular and inconsistent. - !! 08 Jul 2013: (1) dot_product replaces ddotc. - !! 04 Aug 2013: If present(maxxnorm), use maxxnorm_ = min(maxxnorm, one/eps). - !! 09 Sep 2013: Initialize relresl and relAresl to zero. - !!------------------------------------------------------------------ - !! \endverbatim - - subroutine MINRESQLP( n, Aprod, b, shift, Msolve, disable, nout, & - itnlim, rtol, maxxnorm, trancond, Acondlim, & - x, istop, itn, rnorm, Arnorm, xnorm, Anorm, Acond ) - ! Inputs - integer(ip), intent(in) :: n - real(dp), intent(in) :: b(n) - integer(ip), intent(in), optional :: itnlim, nout - logical, intent(in), optional :: disable - real(dp), intent(in), optional :: shift - real(dp), intent(in), optional :: rtol, maxxnorm, trancond, Acondlim - - ! Outputs - real(dp), intent(out) :: x(n) - integer(ip), intent(out), optional :: istop, itn - real(dp), intent(out), optional :: rnorm, Arnorm, xnorm, Anorm, Acond - - optional :: Msolve - - interface - subroutine Aprod(n,x,y) ! y := A*x - use minresqlpDataModule - integer(ip), intent(in) :: n - real(dp), intent(in) :: x(n) - real(dp), intent(out) :: y(n) - end subroutine Aprod - - subroutine Msolve(n,x,y) ! Solve M*y = x - use minresqlpDataModule - integer(ip), intent(in) :: n - real(dp), intent(in) :: x(n) - real(dp), intent(out) :: y(n) - end subroutine Msolve - end interface - - intrinsic :: abs, sqrt, present, floor, log10, dot_product - - ! Local arrays and variables - real(dp) :: shift_ - real(dp) :: rtol_, maxxnorm_, trancond_, Acondlim_ - real(dp) :: rnorm_, Arnorm_, xnorm_, Anorm_, Acond_ - logical :: checkA_, precon_, disable_ - integer(ip) :: itnlim_, nout_, istop_, itn_ - - real(dp) :: r1(n), r2(n), v(n), w(n), wl(n), wl2(n),& - xl2(n), y(n), vec2(2), vec3(3) - real(dp) :: abs_gama, Acondl, alfa, Anorml, Arnorml,& - Axnorm, beta, beta1, betal, betan, & - epsa, epsx, gminl2, ieps, pnorm, & - relAres, relAresl, relres, relresl, & - rnorml, rootl, t1, t2, xl2norm, & - xnorm_tmp, xnorml, z, & - cr1, cr2, cs, dbar, dlta, dlta_QLP, & - dlta_tmp, dltan, epln, eplnn, eta, etal,& - etal2, gama, gama_QLP, gama_tmp, gamal, & - gamal_QLP, gamal_tmp, gamal2, gamal3, & - gbar, gmin, gminl, phi, s, sn, sr1, sr2,& - t, tau, taul, taul2, u, u_QLP, & - ul, ul_QLP, ul2, ul2_QLP, ul3, ul4, & - vepln, vepln_QLP, veplnl, veplnl2, x1last - - integer(ip) :: j, QLPiter, headlines, lines, nprint, flag0, ios - logical :: prnt, done, lastiter, connected, named_file, likeLS - character(len=20) :: filename - character(len=2) :: QLPstr = ' ' - - ! Local constants - real(dp), parameter :: EPSINV = 10.0_dp**floor(log10(one/eps)) - real(dp) :: NORMMAX = 10.0_dp**floor(log10(one/eps)/2) - character(len=*), parameter :: enter = ' Enter MINRES-QLP. ' - character(len=*), parameter :: exitt = ' Exit MINRES-QLP. ' - character(len=*), parameter :: msg(1:15) = & - (/ 'beta_{k+1} < eps. ', & ! 1 - 'beta2 = 0. If M = I, b and x are eigenvectors of A. ', & ! 2 - 'beta1 = 0. The exact solution is x = 0. ', & ! 3 - 'A solution to (poss. singular) Ax = b found, given rtol. ', & ! 4 - 'A solution to (poss. singular) Ax = b found, given eps. ', & ! 5 - 'Pseudoinverse solution for singular LS problem, given rtol. ', & ! 6 - 'Pseudoinverse solution for singular LS problem, given eps. ', & ! 7 - 'The iteration limit was reached. ', & ! 8 - 'The operator defined by Aprod appears to be unsymmetric. ', & ! 9 - 'The operator defined by Msolve appears to be unsymmetric. ', & ! 10 - 'The operator defined by Msolve appears to be indefinite. ', & ! 11 - 'xnorm has exceeded maxxnorm or will exceed it next iteration. ', & ! 12 - 'Acond has exceeded Acondlim or 0.1/eps. ', & ! 13 - 'Least-squares problem but no converged solution yet. ', & ! 14 - 'A null vector obtained, given rtol. ' /) ! 15 - - character(len=*), parameter :: ddebugStr1 = "(a, T5, i0, a, 5(e12.3))" - character(len=*), parameter :: ddebugStr2 = "(5(a, i0, a, e12.3, a))" - - character(len=*), parameter :: headerStr = & - "(// 1p, a, 4x, 'Solution of symmetric Ax = b'" // & - " / ' n =', i7, 6x, '||b|| =', e11.2, 3x," // & - " 'precon =', l4 " // & - " / ' itnlim =', i7, 6x, 'rtol =', e11.2, 3x," // & - " 'shift =', e23.14 " // & - " / ' maxxnorm =', e11.2, 2x, 'Acondlim =', e11.2, 3x,"// & - " 'trancond =', e11.2)" - character(len=*), parameter :: tableHeaderStr = & - "(// ' iter x(1) xnorm rnorm Arnorm '," // & - " 'Compatible LS norm(A) cond(A)')" - character(len=*), parameter :: itnStr = "(1p, i8, e19.10, 7e10.2, a)" - character(len=*), parameter :: finalStr1 = & - "(/ 1p, a, 5x, a, i3, 14x, a, i8 " // & - " / a, 5x, a, e12.4, 5x, a, e12.4 " // & - " / a, 5x, a, e12.4, 5x, a, e12.4 " // & - " / a, 5x, a, e12.4 )" - character(len=*), parameter :: finalStr2 = "( a, 5x, a )" - - !------------------------------------------------------------------ - prnt = .FALSE. - t1 = zero - t2 = zero - gminl = zero - ! Optional inputs - if (present(shift)) then - shift_ = shift - else - shift_ = zero - end if - - checkA_ = .true. - - if (present(disable)) then - disable_ = disable - else - disable_ = .false. - end if - - if (present(itnlim)) then - itnlim_ = itnlim - else - itnlim_ = 4 * n - end if - - connected = .false. - filename = "MINRESQLP_tmp.txt" - nout_ = 10 - - if (present(nout)) then - nout_ = nout - inquire(unit=nout, opened=connected, named=named_file, name=filename) - !write(*,*) connected, named_file, filename - if (.not. connected) then - write(*,*) "File unit 'nout' is not open." - if (nout==5 .or. nout == 6) then - nout_ = 10 - end if - end if - end if - - if (.not. connected) then - write(*,*) 'nout_ = ', nout_ - open(nout_, file=filename, status='unknown', iostat=ios) - write(*,*) 'ios = ', ios - if (ios /= 0) then - write(*,*) "Error opening file '", filename, "'." - STOP - end if - end if - - if (present(rtol)) then - rtol_ = rtol - else - rtol_ = eps - end if - - if (prcsn == 6) then - NORMMAX = 1.0e4_dp - end if - if (present(maxxnorm)) then - maxxnorm_ = min(maxxnorm, one/eps) - else - maxxnorm_ = NORMMAX - end if - - if (present(trancond)) then - trancond_ = min(trancond, NORMMAX) - else - trancond_ = NORMMAX - end if - - if (present(Acondlim)) then - Acondlim_ = min(Acondlim, EPSINV) - else - Acondlim_ = EPSINV - end if - - if (present(Msolve)) then - precon_ = .true. - else - precon_ = .false. - end if - - !------------------------------------------------------------------ - ! Print heading and initialize. - !------------------------------------------------------------------ - nprint = min(n,20) - !debug = .true. - lastiter = .false. - flag0 = 0 - istop_ = flag0 - beta1 = dnrm2(n, b, 1) - ieps = 0.1_dp/eps - itn_ = 0 - QLPiter = 0 - xnorm_ = zero - xl2norm = zero - Axnorm = zero - Anorm_ = zero - Acond_ = one - pnorm = zero - relresl = zero - relAresl = zero - x = zero - xl2 = zero - x1last = x(1) - - if (nout_ > 0) then - write(nout_, headerStr) enter, n, beta1, precon_, itnlim_, rtol_, & - shift_, maxxnorm_, Acondlim_, trancond_ - end if - - !------------------------------------------------------------------ - ! Set up y and v for the first Lanczos vector v1. - ! y = beta1 P'v1, where P = C**(-1). - ! v is really P'v1. - !------------------------------------------------------------------ - y = b - r1 = b - if ( precon_ ) then - call Msolve( n, b, y ) - end if - - beta1 = dot_product(b, y) - - if (beta1 < zero .and. dnrm2(n, y, 1) > eps) then ! M must be indefinite. - istop_ = 11 - end if - - if (beta1 == zero) then ! b = 0 exactly. Stop with x = 0. - istop_ = 3 - end if - - beta1 = sqrt( beta1 ) ! Normalize y to get v1 later. - - if (debug) then - write(*,ddebugStr1) ' y_', itn_, ' = ', (y(j), j=1,nprint) - write(*,*) 'beta1 ', beta1 - end if - - !------------------------------------------------------------------ - ! See if Msolve is symmetric. - !------------------------------------------------------------------ - if (checkA_ .and. precon_) then - call Msolve( n, y, r2 ) - s = dot_product( y, y ) - t = dot_product(r1, r2) - z = abs( s - t ) - epsa = (abs(s) + eps) * eps**0.33333_dp - if (z > epsa) then - istop_ = 10 - end if - end if - - !------------------------------------------------------------------ - ! See if Aprod is symmetric. - !------------------------------------------------------------------ - if (checkA_) then - call Aprod ( n, y, w ) ! w = A*y - call Aprod ( n, w, r2 ) ! r2 = A*w - s = dot_product( w, w ) - t = dot_product( y, r2) - z = abs( s - t ) - epsa = (abs(s) + eps) * eps**0.33333_dp - if (z > epsa) then - istop_ = 9 - end if - end if - - !------------------------------------------------------------------ - ! Initialize other quantities. - !------------------------------------------------------------------ - tau = zero - taul = zero - gmin = zero - beta = zero - betan = beta1 - dbar = zero - dltan = zero - eta = zero - etal = zero - etal2 = zero - vepln = zero - veplnl = zero - veplnl2= zero - eplnn = zero - gama = zero - gamal = zero - gamal2 = zero - phi = beta1 - cr1 = -one - sr1 = zero - cr2 = -one - sr2 = zero - cs = -one - sn = zero - ul3 = zero - ul2 = zero - ul = zero - u = zero - lines = 1 - headlines = 30 * lines - rnorm_ = betan - relres = rnorm_ / (Anorm_*xnorm_ + beta1) - relAres= zero - r2 = b - w = zero ! vector of zeros - wl = zero - done = .false. - - if (debug) then - write(*,*) - write(*,*) 'Checking variable values before main loop' - write(*,*) 'istop ', istop_, ' done ', done, ' itn ', itn_, ' QLPiter' , QLPiter - write(*,*) 'lastiter', lastiter, ' lines ', lines, ' headlines ', headlines - write(*,*) 'beta ', beta, ' tau ', tau, ' taul ', taul, ' phi ', phi - write(*,*) 'betan ', betan, ' gmin ', gmin, ' cs ', cs, ' sn ', sn - write(*,*) 'cr1 ', cr1, ' sr1 ', sr1, ' cr2 ', cr2, ' sr2 ', sr2 - write(*,*) 'dltan ', dltan, ' eplnn ', eplnn, ' gama ', gama, ' gamal ', gamal - write(*,*) 'gamal2 ', gamal2, ' eta ', eta, ' etal ', etal, 'etal2', etal2 - write(*,*) 'vepln ', vepln, ' veplnl', veplnl, ' veplnl2 ', veplnl2, ' ul3 ', ul3 - write(*,*) 'ul2 ', ul2, ' ul ', ul, ' u ', u, ' rnorm ', rnorm_ - write(*,*) 'xnorm ', xnorm_, ' xl2norm ', xl2norm, ' pnorm ', pnorm, ' Axnorm ', Axnorm - write(*,*) 'Anorm ', Anorm_, ' Acond ', Acond_, ' relres ', relres - write(*,ddebugStr1) 'w_', itn_-1, ' = ', (wl(j), j=1,nprint) - write(*,ddebugStr1) 'w_', itn_, ' = ', (w(j), j=1,nprint) - write(*,ddebugStr1) 'x_', itn_, ' = ', (x(j), j=1,nprint) - end if - - - !------------------------------------------------------------------ - ! Main iteration loop. - !------------------------------------------------------------------ - do while (istop_ <= flag0) - itn_ = itn_ + 1 ! k = itn = 1 first time through - - !----------------------------------------------------------------- - ! Obtain quantities for the next Lanczos vector vk+1, k = 1, 2,... - ! The general iteration is similar to the case k = 1 with v0 = 0: - ! - ! p1 = Operator * v1 - beta1 * v0, - ! alpha1 = v1'p1, - ! q2 = p2 - alpha1 * v1, - ! beta2^2 = q2'q2, - ! v2 = (1/beta2) q2. - ! - ! Again, y = betak P vk, where P = C**(-1). - ! .... more description needed. - !----------------------------------------------------------------- - - betal = beta; ! betal = betak - beta = betan; - s = one / beta ! Normalize previous vector (in y). - v = s*y; ! v = vk if P = I. - call Aprod ( n, v, y ) - if (shift_ /= zero) then - y = y - shift_ * v - end if - if (itn_ >= 2) then - y = y + (- beta/betal) * r1 - end if - alfa = dot_product(v, y) ! alphak - y = y + (- alfa/beta) * r2 - r1 = r2 - r2 = y - - if ( .not. precon_ ) then - betan = dnrm2(n, y, 1) ! betan = ||y||_2 - else - call Msolve( n, r2, y ) - betan = dot_product(r2, y) ! betan = betak+1^2 - if (betan > zero) then - betan = sqrt(betan) - elseif ( dnrm2(n, y, 1) > eps ) then ! M must be indefinite. - istop_ = 11 - exit - end if - end if - - if (itn_ == 1) then - vec2(1) = alfa - vec2(2) = betan - pnorm = dnrm2(2, vec2, 1) - else - vec3(1) = beta - vec3(2) = alfa - vec3(3) = betan - pnorm = dnrm2(3, vec3, 1) - end if - - - if (debug) then - write(*,*) - write(*,*) 'Lanczos iteration ', itn_ - write(*,ddebugStr1) 'v_', itn_, ' = ', (v(j), j=1,nprint) - write(*,ddebugStr1) 'r1_', itn_, ' = ', (r1(j), j=1,nprint) - write(*,ddebugStr1) 'r2_', itn_, ' = ', (r2(j), j=1,nprint) - write(*,ddebugStr1) 'y_', itn_, ' = ', (y(j), j=1,nprint) - write(*,ddebugStr2) 'alpha_', itn_, ' = ', alfa, ', ', & - 'beta_', itn_, ' = ', beta, ', ', & - 'beta_', itn_+1, ' = ', betan, ', ', & - 'pnorm_', itn_, ' = ', pnorm - end if - - ! Apply previous left reflection Qk-1 to get - ! [deltak epslnk+1] = [cs sn][dbark 0 ] - ! [gbar k dbar k+1] [sn -cs][alfak betak+1]. - - dbar = dltan - dlta = cs * dbar + sn * alfa ! dlta1 = 0 deltak - epln = eplnn; - gbar = sn * dbar - cs * alfa ! gbar 1 = alfa1 gbar k - eplnn = sn * betan ! eplnn2 = 0 epslnk+1 - dltan = - cs * betan ! dbar 2 = beta2 dbar k+1 - dlta_QLP = dlta; - - if (debug) then - write(*,*) - write(*,*) 'Apply previous left reflection Q_{', itn_-1, ',', itn_, '}' - write(*,ddebugStr2) 'c_', itn_-1, ' = ', cs, ', ', & - 's_', itn_-1, ' = ', sn - write(*,ddebugStr2) 'dlta_', itn_, ' = ', dlta, ', ', & - 'gbar_', itn_, ' = ', gbar, ', ', & - 'epln_', itn_+1, ' = ', eplnn, ', ', & - 'dbar_', itn_+1, ' = ', dltan - end if - - ! Compute the current left reflection Qk - gamal3 = gamal2 - gamal2 = gamal - gamal = gama - call symortho(gbar, betan, cs, sn, gama) - gama_tmp = gama; - taul2 = taul - taul = tau - tau = cs * phi - phi = sn * phi ! phik - Axnorm = sqrt( Axnorm**2 + tau**2 ); - - if (debug) then - write(*,*) - write(*,*) 'Compute the current left reflection Q_{', itn_, ',', itn_+1, '}' - write(*,ddebugStr2) 'c_', itn_, ' = ', cs, ', ', & - 's_', itn_, ' = ', sn - write(*,ddebugStr2) 'tau_', itn_, ' = ', tau, ', ', & - 'phi_', itn_, ' = ', phi, ', ', & - 'gama_', itn_, ' = ', gama - end if - - ! Apply the previous right reflection P{k-2,k} - - if (itn_ > 2) then - veplnl2 = veplnl - etal2 = etal - etal = eta - dlta_tmp = sr2 * vepln - cr2 * dlta - veplnl = cr2 * vepln + sr2 * dlta - dlta = dlta_tmp - eta = sr2 * gama - gama = -cr2 * gama - if (debug) then - write(*,*) - write(*,*) 'Apply the previous right reflection P_{', itn_-2, ',', itn_, '}' - write(*,ddebugStr2) 'cr2_', itn_, ' = ', cr2, ', ', & - 'sr2_', itn_, ' = ', sr2 - write(*,ddebugStr2) 'gamal2_', itn_, ' = ', gamal2, ', ', & - 'gamal_', itn_, ' = ', gamal, ', ', & - 'gama_', itn_, ' = ', gama - write(*,ddebugStr2) 'dlta_', itn_, ' = ', dlta, ', ', & - 'vepln_', itn_-1, ' = ', veplnl - end if - end if - - - ! Compute the current right reflection P{k-1,k}, P_12, P_23,... - if (itn_ > 1) then - call symortho(gamal, dlta, cr1, sr1, gamal_tmp) - gamal = gamal_tmp - vepln = sr1 * gama - gama = -cr1 * gama - - if (debug) then - write(*,*) - write(*,*) 'Apply the current right reflection P_{', itn_-1, ',', itn_, '}' - write(*,ddebugStr2) 'cr1_ ', itn_, ' = ', cr1, ', ', & - 'sr1_' , itn_, ' = ', sr1 - write(*,ddebugStr2) 'gama_', itn_-2, ' = ', gamal2, ', ', & - 'gama_', itn_-1, ' = ', gamal, ', ', & - 'gama_', itn_, ' = ', gama - write(*,ddebugStr2) 'dlta_', itn_, ' = ', dlta, ', ', & - 'vepln_', itn_-1, ' = ', veplnl, ', ', & - 'eta_', itn_, ' = ', eta - end if - end if - - ! Update xnorm - - xnorml = xnorm_ - ul4 = ul3 - ul3 = ul2 - - if (itn_ > 2) then - ul2 = ( taul2 - etal2 * ul4 - veplnl2 * ul3 ) / gamal2 - if (debug) then - write(*,ddebugStr2) 'tau_', itn_-2, ' = ', taul2, ', ', & - 'eta_', itn_-2, ' = ', etal2, ', ', & - 'vepln_', itn_-2, ' = ', veplnl2, ', ', & - 'gama_', itn_-2, ' = ', gamal2 - end if - end if - if (itn_ > 1) then - ul = ( taul - etal * ul3 - veplnl * ul2) / gamal - if (debug) then - write(*,ddebugStr2) 'tau_', itn_-1, ' = ', taul, ', ', & - 'eta_', itn_-1, ' = ', etal, ', ', & - 'vepln_', itn_-1, ' = ', veplnl, ', ', & - 'gamal_', itn_-1, ' = ', gamal - end if - end if - - vec3(1) = xl2norm - vec3(2) = ul2 - vec3(3) = ul - xnorm_tmp = dnrm2(3, vec3, 1) ! norm([xl2norm ul2 ul]); - if (abs(gama) > eps) then ! .and. xnorm_tmp < maxxnorm_) then - if (debug) then - write(*,ddebugStr2) 'tau_', itn_, ' = ', tau, ', ', & - 'eta_', itn_, ' = ', eta, ', ', & - 'vepln_', itn_, ' = ', vepln, ', ', & - 'gama_', itn_, ' = ', gama - end if - u = (tau - eta*ul2 - vepln*ul) / gama - likeLS = relAresl < relresl - vec2(1) = xnorm_tmp - vec2(2) = u - if (likeLS .and. dnrm2(2, vec2, 1) > maxxnorm_) then - u = zero - istop_ = 12 - end if - else - u = zero - istop_ = 14 - end if - vec2(1) = xl2norm - vec2(2) = ul2 - xl2norm = dnrm2(2, vec2, 1) - vec3(1) = xl2norm - vec3(2) = ul - vec3(3) = u - xnorm_ = dnrm2(3, vec3, 1) - - if (Acond_ < trancond_ .and. istop_ == flag0 .and. QLPiter == 0) then !! MINRES updates - wl2 = wl - wl = w - if (gama_tmp > eps) then - s = one / gama_tmp - w = (v - epln*wl2 - dlta_QLP*wl) * s - end if - - if (xnorm_ < maxxnorm_) then - x1last = x(1) - x = x + tau*w - else - istop_ = 12 - lastiter = .true. - end if - - if (debug) then - write(*,*) - write(*,*) 'MINRES updates' - write(*,ddebugStr2) 'gama_tmp_', itn_, ' = ', gama_tmp, ', ', & - 'tau_', itn_, ' = ', tau, ', ', & - 'epln_', itn_, ' = ', epln, ', ', & - 'dlta_QLP_', itn_, ' = ', dlta_QLP - write(*,ddebugStr1) 'v_', itn_ , ' = ', (v(j), j=1,nprint) - write(*,ddebugStr1) 'w_', itn_ , ' = ', (w(j), j=1,nprint) - end if - else !! MINRES-QLP updates - QLPiter = QLPiter + 1; - if (QLPiter == 1) then - xl2 = zero ! vector - if (itn_ > 1) then ! construct w_{k-3}, w_{k-2}, w_{k-1} - if (itn_ > 3) then - wl2 = gamal3*wl2 + veplnl2*wl + etal*w - end if ! w_{k-3} - if (itn_ > 2) then - wl = gamal_QLP*wl + vepln_QLP*w - end if ! w_{k-2} - w = gama_QLP*w - xl2 = x - ul_QLP*wl - u_QLP*w - end if - end if - - if (itn_ == 1) then - wl2 = wl - wl = sr1*v - w = -cr1*v - else if (itn_ == 2) then - wl2 = wl - wl = cr1*w + sr1*v - w = sr1*w - cr1*v - else - wl2 = wl - wl = w - w = sr2*wl2 - cr2*v - wl2 = cr2*wl2 + sr2*v - v = cr1*wl + sr1*w - w = sr1*wl - cr1*w - wl = v - end if - x1last = x(1) - xl2 = xl2 + ul2*wl2 - x = xl2 + ul *wl + u*w - - if (debug) then - write(*,*) - write(*,*) 'MINRESQLP updates' - end if - end if - - if (debug) then - write(*,*) - write(*,*) 'Update u, w, x and xnorm' - write(*,ddebugStr2) 'u_', itn_-2, ' = ', ul2, ', ', & - 'u_', itn_-1, ' = ', ul, ', ', & - 'u_', itn_, ' = ', u - write(*,ddebugStr1) 'w_', itn_-2, ' = ', (wl2(j), j=1,nprint) - write(*,ddebugStr1) 'w_', itn_-1, ' = ', (wl(j), j=1,nprint) - write(*,ddebugStr1) 'w_', itn_, ' = ', (w(j), j=1,nprint) - write(*,ddebugStr1) 'x_', itn_, ' = ', (x(j), j=1,nprint) - write(*,ddebugStr2) 'xnorm_', itn_-2, ' = ', xl2norm, ', ', & - 'xnorm_', itn_-1, ' = ', xnorml, ', ', & - 'xnorm_', itn_, ' = ', xnorm_ - end if - - ! Compute the next right reflection P{k-1,k+1} - - if (debug) then - write(*,*) - write(*,*) 'Compute the next right reflection P{', itn_-1, itn_+1,'}' - write(*,ddebugStr2) 'gama_', itn_-1, ' = ', gamal, ', ', & - 'epln_', itn_+1, ' = ', eplnn - end if - - gamal_tmp = gamal - call symortho(gamal_tmp, eplnn, cr2, sr2, gamal) - - if (debug) then - write(*,ddebugStr2) 'cr2_', itn_+1, ' = ', cr2, ', ', & - 'sr2_', itn_+1, ' = ', sr2, ', ', & - 'gama_', itn_-1, ' = ', gamal - end if - - ! Store quantities for transfering from MINRES to MINRES-QLP - - gamal_QLP = gamal_tmp - vepln_QLP = vepln - gama_QLP = gama - ul2_QLP = ul2 - ul_QLP = ul - u_QLP = u - - if (debug) then - write(*,*) - write(*,*) 'Store quantities for transfering from MINRES to MINRES-QLP ' - write(*,ddebugStr2) 'gama_QLP_', itn_-1, ' = ', gamal_QLP, ', ', & - 'vepln_QLP_',itn_, ' = ', vepln_QLP, ', ', & - 'gama_QLP_', itn_, ' = ', gama_QLP - write(*,ddebugStr2) 'u_QLP_', itn_-2, ' = ', ul2_QLP, ', ', & - 'u_QLP_', itn_-1, ' = ', ul_QLP, ', ', & - 'u_QLP_', itn_, ' = ', u_QLP - end if - - ! Estimate various norms - - abs_gama = abs(gama) - Anorml = Anorm_ - Anorm_ = max(Anorm_, pnorm, gamal, abs_gama) - if (itn_ == 1) then - gmin = gama - gminl = gmin - else if (itn_ > 1) then - gminl2 = gminl - gminl = gmin - vec3(1) = gminl2 - vec3(2) = gamal - vec3(3) = abs_gama - gmin = min(gminl2, gamal, abs_gama) - end if - Acondl = Acond_ - Acond_ = Anorm_ / gmin - rnorml = rnorm_ - relresl = relres - if (istop_ /= 14) rnorm_ = phi - relres = rnorm_ / (Anorm_ * xnorm_ + beta1) - vec2(1) = gbar - vec2(2) = dltan - rootl = dnrm2(2, vec2, 1) - Arnorml = rnorml * rootl - relAresl = rootl / Anorm_ - - if (debug) then - write(*,*) - write(*,*) 'Estimate various norms ' - write(*,ddebugStr2) 'gmin_', itn_, ' = ', gmin, ', ', & - 'pnorm_', itn_, ' = ', pnorm, ', ', & - 'rnorm_', itn_, ' = ', rnorm_, ', ', & - 'Arnorm_', itn_-1, ' = ', Arnorml - write(*,ddebugStr2) 'Axnorm_', itn_, ' = ', Axnorm, ', ', & - 'Anorm_', itn_, ' = ', Anorm_, ', ', & - 'Acond_', itn_, ' = ', Acond_ - end if - - ! See if any of the stopping criteria are satisfied. - - epsx = Anorm_*xnorm_*eps - if (istop_ == flag0 .or. istop_ == 14) then - t1 = one + relres - t2 = one + relAresl - end if - if (t1 <= one ) then - istop_ = 5 ! Accurate Ax=b solution - else if (t2 <= one ) then - istop_ = 7 ! Accurate LS solution - else if (relres <= rtol_ ) then - istop_ = 4 ! Good enough Ax=b solution - else if (relAresl <= rtol_ ) then - istop_ = 6 ! Good enough LS solution - else if (epsx >= beta1 ) then - istop_ = 2 ! x is an eigenvector - else if (xnorm_ >= maxxnorm_) then - istop_ = 12 ! xnorm exceeded its limit - else if (Acond_ >= Acondlim_ .or. Acond_ >= ieps) then - istop_ = 13 ! Huge Acond - else if (itn_ >= itnlim_ ) then - istop_ = 8 ! Too many itns - else if (betan < eps ) then - istop_ = 1 ! Last iteration of Lanczos, rarely happens - end if - - if (disable_ .and. itn_ < itnlim_) then - istop_ = flag0 - done = .false. - if (Axnorm < rtol_*Anorm_*xnorm_) then - istop_ = 15 - lastiter = .false. - end if - end if - - if (istop_ /= flag0) then - done = .true. - if (istop_ == 6 .or. istop_ == 7 .or. istop_ == 12 .or. istop_ == 13) then - lastiter = .true. - end if - if (lastiter) then - itn_ = itn_ - 1 - Acond_ = Acondl - rnorm_ = rnorml - relres = relresl - end if - - call Aprod ( n, x, r1 ) - r1 = b - r1 + shift_*x ! r1 to temporarily store residual vector - call Aprod ( n, r1, wl2 ) ! wl2 to temporarily store A*r1 - wl2 = wl2 - shift_*r1 - Arnorm_ = dnrm2(n, wl2, 1) - if (rnorm_ > zero .and. Anorm_ > zero) then - relAres = Arnorm_ / (Anorm_*rnorm_) - end if - end if - - if (nout_ > 0 .and. .not. lastiter .and. mod(itn_-1,lines) == 0) then - if (itn_ == 101) then - lines = 10 - headlines = 30*lines - else if (itn_ == 1001) then - lines = 100 - headlines = 30*lines - end if - - if (QLPiter == 1) then - QLPstr = ' P' - else - QLPstr = ' ' - end if - end if - - - ! See if it is time to print something. - - if (nout_ > 0) then - prnt = .false. - if (n <= 40 ) prnt = .true. - if (itn_ <= 10 ) prnt = .true. - if (itn_ >= itnlim_ - 10) prnt = .true. - if (mod(itn_-1,10) == 0 ) prnt = .true. - if (QLPiter == 1 ) prnt = .true. - if (Acond_ >= 0.01_dp/eps ) prnt = .true. - if (istop_ /= flag0 ) prnt = .true. - - if ( prnt ) then - if (itn_ == 1) write(nout_, tableHeaderStr) - write(nout_, itnStr) itn_-1, x1last, xnorml, & - rnorml, Arnorml, relresl, relAresl, Anorml, Acondl, QLPstr - if (mod(itn_,10) == 0) write(nout_, "(1x)") - end if - end if - - if (debug) then - write(*,*) 'istop = ', istop_ - end if - if (istop_ /= flag0) exit - enddo - !=================================================================== - ! End of iteration loop. - !=================================================================== - - ! Optional outputs - - if (present(istop)) then - istop = istop_ - end if - - if (present(itn)) then - itn = itn_ - end if - - if (present(rnorm)) then - rnorm = rnorm_ - end if - - if (present(Arnorm)) then - Arnorm = Arnorm_ - end if - - if (present(xnorm)) then - xnorm = xnorm_ - end if - - if (present(Anorm)) then - Anorm = Anorm_ - end if - - if (present(Acond)) then - Acond = Acond_ - end if - - if ( prnt ) then - write(nout_, itnStr) itn_, x(1), xnorm_, & - rnorm_, Arnorm_, relres, relAres, Anorm_, Acond_, QLPstr - end if - - ! Display final status. - - if (nout_ > 0) then - write(nout_, finalStr1) exitt, 'istop =', istop_, 'itn =', itn_, & - exitt, 'Anorm =', Anorm_, 'Acond =', Acond_, & - exitt, 'rnorm =', rnorm_, 'Arnorm =', Arnorm_, & - exitt, 'xnorm =', xnorm_ - write(nout_, finalStr2) exitt, msg(istop_) - end if - - return -end subroutine MINRESQLP - - !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - !> SymOrtho: Stable Householder reflection - !! - !!\verbatim - !! USAGE: - !! SymOrtho(a, b, c, s, r) - !! - !! INPUTS: - !! a first element of a two-vector [a; b] - !! b second element of a two-vector [a; b] - !! - !! OUTPUTS: - !! c cosine(theta), where theta is the implicit angle of reflection - !! s sine(theta) - !! r two-norm of [a; b] - !! - !! DESCRIPTION: - !! Stable Householder reflection that gives c and s such that - !! [ c s ][a] = [r], - !! [ s -c ][b] [0] - !! where r = two norm of vector [a, b], - !! c = a / sqrt(a**2 + b**2) = a / r, - !! s = b / sqrt(a**2 + b**2) = b / r. - !! The implementation guards against overlow in computing sqrt (a**2 + b**2). - !! - !! - !! REFERENCES: - !! Algorithm 4.9, stable unsymmetric Givens rotations in - !! Golub and van Loan's book Matrix Computations, 3rd edition. - !! - !! MODIFICATION HISTORY: - !! 20/08/2012: Fixed a bug to ensure the 2x2 Hermitian reflectors - !! are orthonormal. - !! 05/27/2011: Created this file from Matlab SymGivens2.m - !! - !! KNOWN BUGS: - !! MM/DD/2004: description - !! - !! AUTHORS: Sou-Cheng Choi, CI, University of Chicago - !! Michael Saunders, MS&E, Stanford University - !! - !! CREATION DATE: 05/27/2011 - !!\endverbatim - !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - subroutine SYMORTHO(a, b, c, s, r) - - real(dp), intent(in) :: a, b - real(dp), intent(out) :: c, s, r - - intrinsic :: abs, sqrt - - ! Local variables - logical, parameter :: debug = .false. - real(dp) :: t - real(dp) :: abs_a, abs_b - - abs_a = abs(a) - abs_b = abs(b) - - if (abs_b <= realmin) then - s = zero - r = abs_a - if (a == zero) then - c = one - else - c = a / abs_a - end if - - else if (abs_a <= realmin) then - c = zero; - r = abs_b - s = b / abs_b - - else if (abs_b > abs_a) then - t = a / b - s = (b / abs_b) / sqrt(one + t**2) - c = s * t - r = b / s ! computationally better than r = a / c since |c| <= |s| - - else - t = b / a - c = (a / abs_a) / sqrt(one + t**2) - s = c * t; - r = a / c ! computationally better than r = b / s since |s| <= |c| - end if - - if (debug) then - write(*,*) 'c = ', c, ', s = ', s, ', r = ', r - end if - - end subroutine SYMORTHO - -end module minresqlpModule diff --git a/millepede/mp2-logo.png b/millepede/mp2-logo.png deleted file mode 100644 index 9173494e5d..0000000000 Binary files a/millepede/mp2-logo.png and /dev/null differ diff --git a/millepede/mpbits.f90 b/millepede/mpbits.f90 deleted file mode 100644 index 4d54ba7b2d..0000000000 --- a/millepede/mpbits.f90 +++ /dev/null @@ -1,824 +0,0 @@ -!> \file -!! Bit field counters. -!! -!! \author Volker Blobel, University Hamburg, 2005-2009 (initial Fortran77 version) -!! \author Claus Kleinwort, DESY (maintenance and developement) -!! -!! \copyright -!! Copyright (c) 2009 - 2015 Deutsches Elektronen-Synchroton, -!! Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n -!! 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. \n\n -!! 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. \n\n -!! You should have received a copy of the GNU Library General Public -!! License along with this program (see the file COPYING.LIB for more -!! details); if not, write to the Free Software Foundation, Inc., -!! 675 Mass Ave, Cambridge, MA 02139, USA. -!! -!! Count pairs of global parameters for sparse storage of global matrix, -!! apply pair entries cut and build (compressed) sparsity structure (row offsets, column lists). -!! -!! In sparse storage mode for each row the list of column indices with non zero elements -!! (and those elements) are stored. With compression this list is represented by the -!! first column and their number for continous regions (encoded in single INTEGER(mpi) words). -!! Rare elements may be stored in single precision. -!! -!! An additional bit map is used to monitor the parameter pairs for measurements (or 'equations'). -!! - -!> Bit field data. -MODULE mpbits - USE mpdef - IMPLICIT NONE - - INTEGER(mpl) :: ndimb !< dimension for bit (field) array - INTEGER(mpl) :: ndimb2 !< dimension for bit map - INTEGER(mpi) :: n !< matrix size (counters) - INTEGER(mpi) :: n2 !< matrix size (map) - INTEGER(mpi) :: ibfw !< bit field width - INTEGER(mpi) :: ireqpe !< min number of pair entries - INTEGER(mpi) :: isngpe !< upper bound for pair entry single precision storage - INTEGER(mpi) :: icmprs !< compression flag for sparsity (column indices) - INTEGER(mpi) :: iextnd !< flag for extended storage (both 'halves' of sym. mat. for improved access patterns) - INTEGER(mpi) :: nspc !< number of precision for sparse global matrix (1=D, 2=D+f) - INTEGER(mpi) :: mxcnt !< max value for bit field counters - INTEGER(mpi) :: nencdm !< max value for column counter - INTEGER(mpi) :: nencdb !< number of bits for encoding column counter - INTEGER(mpi) :: nthrd !< number of threads - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: bitFieldCounters !< fit field counters for global parameters pairs (tracks) - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: bitMap !< fit field map for global parameters pairs (measurements) - INTEGER(mpi), PARAMETER :: bs = BIT_SIZE(1_mpi) !< number of bits in INTEGER(mpi) - -END MODULE mpbits - -!> Fill bit fields (counters). -!! -!! \param [in] im first index -!! \param [in] jm second index -!! \param [in] inc increment (usually 1) -!! -SUBROUTINE inbits(im,jm,inc) ! include element (I,J) - USE mpbits - - INTEGER(mpi), INTENT(IN) :: im - INTEGER(mpi), INTENT(IN) :: jm - INTEGER(mpi), INTENT(IN) :: inc - - INTEGER(mpl) :: l - INTEGER(mpl) :: ll - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: noffj - INTEGER(mpi) :: m - INTEGER(mpi) :: mm - INTEGER(mpi) :: icount - INTEGER(mpi) :: ib - INTEGER(mpi) :: jcount - INTEGER(mpl) :: noffi - LOGICAL :: btest - - IF(im == jm) RETURN ! diagonal - j=MIN(im,jm) - i=MAX(im,jm) - IF(j <= 0) RETURN ! out low - IF(i > n) RETURN ! out high - noffi=INT(i-1,mpl)*INT(i-2,mpl)*INT(ibfw,mpl)/2 ! for J=1 - noffj=(j-1)*ibfw - l=noffi/bs+i+noffj/bs ! row offset + column offset - ! add I instead of 1 to keep bit maps of different rows in different words (openMP !) - m=MOD(noffj,bs) - IF (ibfw <= 1) THEN - bitFieldCounters(l)=ibset(bitFieldCounters(l),m) - ELSE - ! get counter from bit field - ll=l - mm=m - icount=0 - DO ib=0,ibfw-1 - IF (btest(bitFieldCounters(ll),mm)) icount=ibset(icount,ib) - mm=mm+1 - IF (mm >= bs) THEN - ll=ll+1 - mm=mm-bs - END IF - END DO - ! increment - jcount=icount - icount=MIN(icount+inc,mxcnt) - ! store counter into bit field - IF (icount /= jcount) THEN - ll=l - mm=m - DO ib=0,ibfw-1 - IF (btest(icount,ib)) THEN - bitFieldCounters(ll)=ibset(bitFieldCounters(ll),mm) - ELSE - bitFieldCounters(ll)=ibclr(bitFieldCounters(ll),mm) - END IF - mm=mm+1 - IF (mm >= bs) THEN - ll=ll+1 - mm=mm-bs - END IF - END DO - END IF - END IF - RETURN - -END SUBROUTINE inbits - -!> Calculate bit (field) array size, encoding. -!! -!! \param [in] in matrix size -!! \param [in] jreqpe min number of pair entries -!! \param [in] jhispe mupper bound for pair entry histogrammimg -!! \param [in] jsngpe upper bound for pair entry single precision storage -!! \param [in] jcmprs compression flag for sparsity (column indices) -!! \param [in] jextnd flag for extended storage -!! \param [out] idimb dimension for bit (field) array -!! \param [out] iencdb number of bits for encoding column counter -!! \param [out] ispc number of precision for sparse global matrix -!! -SUBROUTINE clbits(in,jreqpe,jhispe,jsngpe,jcmprs,jextnd,idimb,iencdb,ispc) - USE mpbits - USE mpdalc - - INTEGER(mpi), INTENT(IN) :: in - INTEGER(mpi), INTENT(IN) :: jreqpe - INTEGER(mpi), INTENT(IN) :: jhispe - INTEGER(mpi), INTENT(IN) :: jsngpe - INTEGER(mpi), INTENT(IN) :: jcmprs - INTEGER(mpi), INTENT(IN) :: jextnd - INTEGER(mpl), INTENT(OUT) :: idimb - INTEGER(mpi), INTENT(OUT) :: iencdb - INTEGER(mpi), INTENT(OUT) :: ispc - - INTEGER(mpl) :: noffd - INTEGER(mpi) :: i - INTEGER(mpi) :: icount - INTEGER(mpi) :: mb - INTEGER(mpi) :: nbcol - !$ INTEGER(mpi) :: OMP_GET_MAX_THREADS - ! save input parameter - n=in - ireqpe=jreqpe - isngpe=jsngpe - icmprs=jcmprs+jextnd ! enforce compression for extended storage - iextnd=jextnd - ! number of precision types (D, F) - ispc=1 - if (jsngpe>0) ispc=2 - nspc = ispc - ! bit field size - icount=MAX(jsngpe+1,jhispe) - icount=MAX(jreqpe,icount) - ibfw=1 ! number of bits needed to count up to ICOUNT - mxcnt=1 - DO i=1,30 - IF (icount > mxcnt) THEN - ibfw=ibfw+1 - mxcnt=mxcnt*2+1 - END IF - END DO - ! bit field array size - noffd=INT(n,mpl)*INT(n-1,mpl)*INT(ibfw,mpl)/2 - ndimb=noffd/bs+n - idimb=ndimb - mb=INT(4.0E-6*REAL(ndimb,mps),mpi) - WRITE(*,*) ' ' - WRITE(*,*) 'CLBITS: symmetric matrix of dimension',n - WRITE(*,*) 'CLBITS: off-diagonal elements',noffd - IF (mb > 0) THEN - WRITE(*,*) 'CLBITS: dimension of bit-array',ndimb , '(',mb,'MB)' - ELSE - WRITE(*,*) 'CLBITS: dimension of bit-array',ndimb , '(< 1 MB)' - END IF - CALL mpalloc(bitFieldCounters,ndimb,'INBITS: bit storage') - bitFieldCounters=0 - ! encoding for compression - nbcol=bs/2 ! one half of the bits for column number, other for column counter - DO i=bs/2,bs-2 - IF (btest(n,i)) nbcol=i+1 ! more bits for column number - END DO - nencdb=bs-nbcol - iencdb=nencdb - nencdm=ishft(1,nencdb)-1 - nthrd=1 - !$ NTHRD=OMP_GET_MAX_THREADS() - RETURN -END SUBROUTINE clbits - -!> Analyze bit fields. -!! -!! \param [out] ndims (1): (reduced) size of bit array; (2): size of column lists; -!! (3/4): number of (double/single precision) off diagonal elements; -!! \param[out] ncmprs compression info (per row) -!! \param[out] nsparr row offsets -!! \param[in] ihst >0: histogram number -!! -SUBROUTINE ndbits(ndims,ncmprs,nsparr,ihst) - USE mpbits - - INTEGER(mpl), DIMENSION(4), INTENT(OUT) :: ndims - INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: ncmprs - INTEGER(mpl), DIMENSION(:,:), INTENT(OUT) :: nsparr - INTEGER(mpi), INTENT(IN) :: ihst - - INTEGER(mpi) :: nwcp(0:1) - INTEGER(mpi) :: irgn(2) - INTEGER(mpi) :: inr(2) - INTEGER(mpi) :: ichunk - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: m - INTEGER(mpi) :: last - INTEGER(mpi) :: lrgn - INTEGER(mpi) :: next - INTEGER(mpi) :: icp - INTEGER(mpi) :: mm - INTEGER(mpi) :: jp - INTEGER(mpi) :: nj - INTEGER(mpi) :: ib - INTEGER(mpi) :: ir - INTEGER(mpi) :: icount - INTEGER(mpi) :: iproc - INTEGER(mpi) :: iword - INTEGER(mpi) :: k - INTEGER(mpi) :: mb - INTEGER(mpi) :: n1 - INTEGER(mpl) :: ll - INTEGER(mpl) :: lb - INTEGER(mpl) :: nin - INTEGER(mpl) :: ntot - INTEGER(mpl) :: noffi - REAL(mps) :: cpr - REAL(mps) :: fracu - REAL(mps) :: fracz - LOGICAL :: btest - !$ INTEGER(mpi) :: OMP_GET_THREAD_NUM - - ndims(1)=ndimb - ndims(2)=0 - ndims(3)=0 - ndims(4)=0 - ntot=0 - ll=0 - lb=0 - ichunk=MIN((n+nthrd-1)/nthrd/32+1,256) - IF (ibfw > 1.OR.icmprs > 0) THEN - ! reduce bit field counters to (precision type) bits, analyze precision type bit fields ('1st half' (j= bs) THEN - ll=ll+1 - mm=mm-bs - END IF - END DO - - IF (icount > 0) THEN - ntot=ntot+1 - IF (iproc == 0.AND.ihst > 0) CALL hmpent(ihst,REAL(icount,mps)) - END IF - - ! keep pair ? - IF (icount >= ireqpe) THEN - next=1 ! double - IF (icount <= isngpe) next=2 ! single - iword=ibset(iword,mb+next-1) - inr(next)=inr(next)+1 - IF (next /= last.OR.lrgn >= nencdm) THEN - irgn(next)=irgn(next)+1 - lrgn=0 - END IF - lrgn=lrgn+1 - END IF - last=next - - mb=mb+nspc - IF (mb >= bs) THEN - bitFieldCounters(lb)=iword ! store - iword=0 - lb=lb+1 - mb=mb-bs - END IF - END DO - bitFieldCounters(lb)=iword ! store - - ! save row statistics - ir=i+1 - DO jp=1,nspc - nsparr(1,ir)=irgn(jp) ! number of regions per row and precision - nsparr(2,ir)=inr(jp) ! number of columns per row and precision - ir=ir+n+1 - END DO - END DO - - ! analyze precision type bit fields for extended storage, check for row compression - - ! parallelize row loop - ! private copy of NDIMS for each thread, combined at end, init with 0. - !$OMP PARALLEL DO & - !$OMP PRIVATE(I,NOFFI,NOFFJ,LL,MM,INR,IRGN,LAST,LRGN,J,NEXT,ICP,NWCP,JP,IR,IB) & - !$OMP REDUCTION(+:NDIMS) & - !$OMP SCHEDULE(DYNAMIC,ICHUNK) - DO i=1,n - ! restore row statistics - irgn(1)=INT(nsparr(1,i+1),mpi) - irgn(2)=INT(nsparr(1,i+n+2),mpi) - inr(1)=INT(nsparr(2,i+1),mpi) - inr(2)=INT(nsparr(2,i+n+2),mpi) - - ! analyze precision type bit fields for extended storage ('2nd half' (j>i) too) ? - IF (iextnd > 0) THEN - - noffj=(i-1)*nspc - mm=MOD(noffj,bs) - - last=0 - lrgn=0 - - ! remaining columns - DO j=i+1, n - ! index for pair (J,I) - noffi=INT(j-1,mpl)*INT(j-2,mpl)*INT(ibfw,mpl)/2 ! for I=1 - ll=noffi/bs+j+noffj/bs ! row offset + column offset - - ! get precision type - next=0 - DO ib=0,nspc-1 - IF (btest(bitFieldCounters(ll),mm+ib)) next=ibset(next,ib) - END DO - - ! keep pair ? - IF (next > 0) THEN - inr(next)=inr(next)+1 - IF (next /= last.OR.lrgn >= nencdm) THEN - irgn(next)=irgn(next)+1 - lrgn=0 - END IF - lrgn=lrgn+1 - END IF - last=next - END DO - END IF - - ! row statistics, compression - ir=i+1 - DO jp=1,nspc - icp=0 - nwcp(0)=inr(jp) ! list of column indices (default) - IF (inr(jp) > 0) THEN - nwcp(1)=irgn(jp)+(irgn(jp)+7)/8 ! list of regions of consecutive columns (and group offsets) - ! compress row ? - IF ((nwcp(1) < nwcp(0).AND.icmprs > 0).OR.iextnd > 0) THEN - icp=1 - ncmprs(i+n*(jp-1))=irgn(jp) ! number of regions per row and precision - END IF - ! total space - ndims(2) =ndims(2) +nwcp(icp) - ndims(jp+2)=ndims(jp+2)+nwcp(0) - END IF - ! per row and precision - nsparr(1,ir)=nwcp(icp) - nsparr(2,ir)=nwcp(0) - ir=ir+n+1 - END DO - END DO - !$OMP END PARALLEL DO - - ! sum up, fill row offsets - lb=1 - n1=0 - ll=n+1 - DO jp=1,nspc - DO i=1,n - n1=n1+1 - nsparr(1,n1)=lb - nsparr(2,n1)=ll - lb=lb+nsparr(1,n1+1) - ll=ll+nsparr(2,n1+1) - END DO - n1=n1+1 - nsparr(1,n1)=lb - nsparr(2,n1)=ll - ll=1 - END DO - - ELSE - - nin=0 - nsparr(1,1)=1 - nsparr(2,1)=n+1 - n1=1 - DO i=1,n - noffi=INT(i-1,mpl)*INT(i-2,mpl)/2 - ll=noffi/bs+i - nj=(i-1)/bs - DO k=0,nj - DO m=0,bs-1 - IF(btest(bitFieldCounters(ll+k),m)) nin=nin+1 - END DO - END DO - n1=n1+1 - nsparr(1,n1)=nsparr(1,1)+nin - nsparr(2,n1)=nsparr(2,1)+nin - END DO - ndims(2)=nin - ndims(3)=nin - ntot=nin - - END IF - - nin=ndims(3)+ndims(4) - fracz=200.0*REAL(ntot,mps)/REAL(n,mps)/REAL(n-1,mps) - fracu=200.0*REAL(nin,mps)/REAL(n,mps)/REAL(n-1,mps) - WRITE(*,*) ' ' - WRITE(*,*) 'NDBITS: number of diagonal elements',n - WRITE(*,*) 'NDBITS: number of used off-diagonal elements',nin - WRITE(*,1000) 'fraction of non-zero off-diagonal elements', fracz - WRITE(*,1000) 'fraction of used off-diagonal elements', fracu - IF (icmprs /= 0) THEN - cpr=100.0*REAL(mpi*ndims(2)+mpd*ndims(3)+mps*ndims(4),mps)/REAL((mpd+mpi)*nin,mps) - WRITE(*,1000) 'compression ratio for off-diagonal elements', cpr - END IF -1000 FORMAT(' NDBITS: ',a,f6.2,' %') - RETURN -END SUBROUTINE ndbits - -!> Check sparsity of matrix. -!! -!! \param [out] ndims (1): (reduced) size of bit array; (2): size of column lists; -!! (3/4): number of (double/single precision) off diagonal elements; -!! -SUBROUTINE ckbits(ndims) - USE mpbits - - INTEGER(mpl), DIMENSION(4), INTENT(OUT) :: ndims - - INTEGER(mpi) :: nwcp(0:1) - INTEGER(mpi) :: irgn(2) - INTEGER(mpi) :: inr(2) - INTEGER(mpl) :: ll - INTEGER(mpl) :: noffi - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: last - INTEGER(mpi) :: lrgn - INTEGER(mpi) :: next - INTEGER(mpi) :: icp - INTEGER(mpi) :: ib - INTEGER(mpi) :: icount - INTEGER(mpi) :: kbfw - INTEGER(mpi) :: jp - INTEGER(mpi) :: mm - LOGICAL :: btest - - DO i=1,4 - ndims(i)=0 - END DO - kbfw=1 - IF (ibfw > 1.AND.icmprs > 0) kbfw=2 - ll=0 - - DO i=1,n - noffi=INT(i-1,mpl)*INT(i-2,mpl)*INT(ibfw,mpl)/2 - ll=noffi/bs+i - mm=0 - inr(1)=0 - inr(2)=0 - irgn(1)=0 - irgn(2)=0 - last=0 - lrgn=0 - DO j=1,i-1 - icount=0 - next=0 - DO ib=0,ibfw-1 - IF (btest(bitFieldCounters(ll),mm)) icount=ibset(icount,ib) - mm=mm+1 - IF (mm >= bs) THEN - ll=ll+1 - mm=mm-bs - END IF - END DO - - IF (icount > 0) ndims(1)=ndims(1)+1 - ! keep pair ? - IF (icount >= ireqpe) THEN - next=1 ! double - IF (icount <= isngpe) next=2 ! single - inr(next)=inr(next)+1 - IF (next /= last.OR.lrgn >= nencdm) THEN - irgn(next)=irgn(next)+1 - lrgn=0 - END IF - lrgn=lrgn+1 - END IF - last=next - END DO - - IF (icmprs > 0) THEN - DO jp=1,kbfw - IF (inr(jp) > 0) THEN - icp=0 - nwcp(0)=inr(jp) ! list of column indices (default) - nwcp(1)=irgn(jp)+(irgn(jp)+7)/8 ! list of regions of consecutive columns - ! compress row ? - IF (nwcp(1) < nwcp(0).OR. iextnd > 0) icp=1 - ndims(2) =ndims(2) +nwcp(icp) - ndims(jp+2)=ndims(jp+2)+nwcp(0) - END IF - END DO - ELSE - ndims(2)=ndims(2)+inr(1) - ndims(3)=ndims(3)+inr(1) - END IF - - END DO - - RETURN -END SUBROUTINE ckbits - -!> Create sparsity information. -!! -!! \param[in ] nsparr row offsets -!! \param[out] nsparc column indices -!! \param[in,out] ncmprs compression info (per row, in: number of all regions, out: number of regions in 1st half (for accessing 2nd half)) -!! -SUBROUTINE spbits(nsparr,nsparc,ncmprs) ! collect elements - USE mpbits - USE mpdalc - - INTEGER(mpl), DIMENSION(:,:), INTENT(IN) :: nsparr - INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: nsparc - INTEGER(mpi), DIMENSION(:), INTENT(INOUT) :: ncmprs - - INTEGER(mpl) :: kl - INTEGER(mpl) :: l - INTEGER(mpl) :: ll - INTEGER(mpl) :: l1 - INTEGER(mpl) :: k8 - INTEGER(mpl) :: n1 - INTEGER(mpl) :: noffi - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: j1 - INTEGER(mpi) :: jb - INTEGER(mpi) :: jn - INTEGER(mpi) :: m - INTEGER(mpi) :: ichunk - INTEGER(mpi) :: next - INTEGER(mpi) :: last - INTEGER(mpi) :: lrgn - INTEGER(mpi) :: nrgn - INTEGER(mpi) :: nrgn8 - LOGICAL :: btest - - ichunk=MIN((n+nthrd-1)/nthrd/32+1,256) - - DO jb=0,nspc-1 - ! parallelize row loop - !$OMP PARALLEL DO & - !$OMP PRIVATE(I,N1,NOFFI,NOFFJ,L,M,KL,L1,NRGN,NRGN8,K8,LAST,LRGN,LL,J1,JN,J,NEXT) & - !$OMP SCHEDULE(DYNAMIC,ICHUNK) - DO i=1,n - n1=i+jb*(n+1) - noffi=INT(i-1,mpl)*INT(i-2,mpl)*INT(ibfw,mpl)/2 - l=noffi/bs+i - m=jb - kl=nsparr(1,n1)-1 ! pointer to row in NSPARC - l1=nsparr(2,n1) ! pointer to row in sparse matrix - nrgn=ncmprs(i+n*jb)! compression (number of consecutive regions) - nrgn8=(nrgn+7)/8 ! number of groups (1 offset per group) - k8=kl - kl=kl+nrgn8 ! reserve space of offsets - last=0 - lrgn=0 - ll=l1-1 - j1=0 - jn=0 - - DO j=1,i-1 ! loop for off-diagonal elements - next=0 - IF(bitFieldCounters(l) /= 0) THEN - IF(btest(bitFieldCounters(l),m)) THEN - ll=ll+1 - IF (nrgn <= 0) THEN - kl=kl+1 - nsparc(kl)=j ! column index - ELSE - next=1 - IF (last == 0.OR.jn >= nencdm) THEN - IF (MOD(lrgn,8) == 0) THEN - k8=k8+1 - nsparc(k8)=INT(ll-l1,mpi) - END IF - lrgn=lrgn+1 - kl=kl+1 - j1=ishft(j,nencdb) - jn=0 - END IF - jn=jn+1 - nsparc(kl)=ior(j1,jn) - END IF - END IF - END IF - last=next - m=m+nspc - IF (m >= bs) THEN - m=m-bs - l=l+1 - END IF - END DO - - ! extended storage ('2nd half' too) ? - IF (iextnd > 0) THEN - noffj=(i-1)*nspc - m=MOD(noffj,bs)+jb - last=0 - ncmprs(i+n*jb)=lrgn ! remember number of regions in 1st half (j= nencdm) THEN - IF (MOD(lrgn,8) == 0) THEN - k8=k8+1 - nsparc(k8)=INT(ll-l1,mpi) - END IF - lrgn=lrgn+1 - kl=kl+1 - j1=ishft(j,nencdb) - jn=0 - END IF - jn=jn+1 - nsparc(kl)=ior(j1,jn) - END IF - END IF - last=next - - END DO - END IF - - END DO - !$OMP END PARALLEL DO - - END DO - - n1=(n+1)*ibfw - WRITE(*,*) ' ' - WRITE(*,*) 'SPBITS: sparse structure constructed ',nsparr(1,n1), ' words' - WRITE(*,*) 'SPBITS: dimension parameter of matrix',nsparr(2,1)-1 - IF (ibfw <= 1) THEN - WRITE(*,*) 'SPBITS: index of last used location',nsparr(2,n1)-1 - ELSE - WRITE(*,*) 'SPBITS: index of last used double',nsparr(2,n1/2)-1 - WRITE(*,*) 'SPBITS: index of last used single',nsparr(2,n1)-1 - END IF - CALL mpdealloc(bitFieldCounters) - RETURN -END SUBROUTINE spbits - - -!> Clear (additional) bit map. -!! -!! \param [in] in matrix size -! -SUBROUTINE clbmap(in) - USE mpbits - USE mpdalc - - INTEGER(mpi), INTENT(IN) :: in - - INTEGER(mpl) :: noffd - INTEGER(mpi) :: mb - - ! save input parameter - n2=in - ! bit field array size - noffd=INT(n2,mpl)*INT(n2-1,mpl)/2 - ndimb2=noffd/bs+n2 - mb=INT(4.0E-6*REAL(ndimb2,mps),mpi) - WRITE(*,*) ' ' - IF (mb > 0) THEN - WRITE(*,*) 'CLBMAP: dimension of bit-map',ndimb2 , '(',mb,'MB)' - ELSE - WRITE(*,*) 'CLBMAP: dimension of bit-map',ndimb2 , '(< 1 MB)' - END IF - CALL mpalloc(bitMap,ndimb2,'INBMAP: bit storage') - bitMap=0 - RETURN -END SUBROUTINE clbmap - -!> Fill bit map. -!! -!! \param [in] im first index -!! \param [in] jm second index -!! -SUBROUTINE inbmap(im,jm) ! include element (I,J) - USE mpbits - - INTEGER(mpi), INTENT(IN) :: im - INTEGER(mpi), INTENT(IN) :: jm - - INTEGER(mpl) :: l - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: noffj - INTEGER(mpl) :: noffi - INTEGER(mpi) :: m - - IF(im == jm) RETURN ! diagonal - j=MIN(im,jm) - i=MAX(im,jm) - IF(j <= 0) RETURN ! out low - IF(i > n2) RETURN ! out high - noffi=INT(i-1,mpl)*INT(i-2,mpl)/2 ! for J=1 - noffj=(j-1) - l=noffi/bs+i+noffj/bs ! row offset + column offset - ! add I instead of 1 to keep bit maps of different rows in different words (openMP !) - m=MOD(noffj,bs) - bitMap(l)=ibset(bitMap(l),m) - RETURN -END SUBROUTINE inbmap - -!> Get pairs (statistic) from map. -!! -!! \param [out] npair number of paired parameters -!! -SUBROUTINE gpbmap(npair) - USE mpbits - - INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: npair - - INTEGER(mpl) :: l - INTEGER(mpl) :: noffi - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: m - LOGICAL :: btest - - npair(1:n2)=0 - l=0 - - DO i=1,n2 - noffi=INT(i-1,mpl)*INT(i-2,mpl)/2 - l=noffi/bs+i - m=0 - DO j=1,i-1 - IF (btest(bitMap(l),m)) THEN - npair(i)=npair(i)+1 - npair(j)=npair(j)+1 - END IF - m=m+1 - IF (m >= bs) THEN - l=l+1 - m=m-bs - END IF - END DO - END DO - - RETURN -END SUBROUTINE gpbmap diff --git a/millepede/mpdalc.f90 b/millepede/mpdalc.f90 deleted file mode 100644 index 90c9929e74..0000000000 --- a/millepede/mpdalc.f90 +++ /dev/null @@ -1,269 +0,0 @@ -!> \file -!! Dynamic memory management. -!! -!! \author Claus Kleinwort, DESY, 2012 (Claus.Kleinwort@desy.de) -!! -!! \copyright -!! Copyright (c) 2012 - 2015 Deutsches Elektronen-Synchroton, -!! Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n -!! 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. \n\n -!! 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. \n\n -!! You should have received a copy of the GNU Library General Public -!! License along with this program (see the file COPYING.LIB for more -!! details); if not, write to the Free Software Foundation, Inc., -!! 675 Mass Ave, Cambridge, MA 02139, USA. -!! - -!> (De)Allocate vectors and arrays. -MODULE mpdalc - USE mpdef - IMPLICIT NONE - SAVE - ! variables - INTEGER(mpl) :: numwordsalloc = 0 !< current dynamic memory allocation (words) - INTEGER(mpl) :: maxwordsalloc = 0 !< peak dynamic memory allocation (words) - INTEGER(mpi) :: nummpalloc = 0 !< number of dynamic allocations - INTEGER(mpi) :: nummpdealloc = 0 !< number of dynamic deallocations - INTEGER(mpi) :: printflagalloc = 0 !< print flag for dynamic allocations - - !> allocate array - INTERFACE mpalloc - MODULE PROCEDURE mpallocdvec, mpallocfvec, mpallocivec, & - mpallocfarr, mpallociarr, mpalloclarr, mpalloclist, mpalloccvec - END INTERFACE mpalloc - !> deallocate array - INTERFACE mpdealloc - MODULE PROCEDURE mpdeallocdvec, mpdeallocfvec, mpdeallocivec, & - mpdeallocfarr, mpdeallociarr, mpdealloclarr, mpdealloclist, mpdealloccvec - END INTERFACE mpdealloc - -CONTAINS - ! allocate dynamic vector or array - !> allocate (1D) double precision array - SUBROUTINE mpallocdvec(array,length,text) - REAL(mpd), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array - INTEGER(mpl), INTENT(IN) :: length - CHARACTER (LEN=*), INTENT(IN) :: text - - INTEGER(mpi) :: ifail - ALLOCATE (array(length),stat=ifail) - CALL mpalloccheck(ifail,(mpd*length)/mpi,text) - END SUBROUTINE mpallocdvec - - !> allocate (1D) single precision array - SUBROUTINE mpallocfvec(array,length,text) - REAL(mps), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array - INTEGER(mpl), INTENT(IN) :: length - CHARACTER (LEN=*), INTENT(IN) :: text - - INTEGER(mpi) :: ifail - ALLOCATE (array(length),stat=ifail) - CALL mpalloccheck(ifail,(mps*length)/mpi,text) - END SUBROUTINE mpallocfvec - - !> allocate (1D) integer array - SUBROUTINE mpallocivec(array,length,text) - INTEGER(mpi), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array - INTEGER(mpl), INTENT(IN) :: length - CHARACTER (LEN=*), INTENT(IN) :: text - - INTEGER(mpi) :: ifail - ALLOCATE (array(length),stat=ifail) - CALL mpalloccheck(ifail,length,text) - END SUBROUTINE mpallocivec - - !> allocate (2D) single precision array - SUBROUTINE mpallocfarr(array,rows,cols,text) - REAL(mps), DIMENSION(:,:), INTENT(IN OUT), ALLOCATABLE :: array - INTEGER(mpl), INTENT(IN) :: rows - INTEGER(mpl), INTENT(IN) :: cols - CHARACTER (LEN=*), INTENT(IN) :: text - - INTEGER(mpi) :: ifail - ALLOCATE (array(rows,cols),stat=ifail) - CALL mpalloccheck(ifail,(mps*rows*cols)/mpi,text) - END SUBROUTINE mpallocfarr - - !> allocate (2D) INTEGER(mpi) array - SUBROUTINE mpallociarr(array,rows,cols,text) - INTEGER(mpi), DIMENSION(:,:), INTENT(IN OUT), ALLOCATABLE :: array - INTEGER(mpl), INTENT(IN) :: rows - INTEGER(mpl), INTENT(IN) :: cols - CHARACTER (LEN=*), INTENT(IN) :: text - - INTEGER(mpi) :: ifail - ALLOCATE (array(rows,cols),stat=ifail) - CALL mpalloccheck(ifail,rows*cols,text) - END SUBROUTINE mpallociarr - - !> allocate (2D) large integer array - SUBROUTINE mpalloclarr(array,rows,cols,text) - INTEGER(mpl), DIMENSION(:,:), INTENT(IN OUT), ALLOCATABLE :: array - INTEGER(mpl), INTENT(IN) :: rows - INTEGER(mpl), INTENT(IN) :: cols - CHARACTER (LEN=*), INTENT(IN) :: text - - INTEGER(mpi) :: ifail - ALLOCATE (array(rows,cols),stat=ifail) - CALL mpalloccheck(ifail,(mpl*rows*cols)/mpi,text) - END SUBROUTINE mpalloclarr - - !> allocate (1D) list item array - SUBROUTINE mpalloclist(array,length,text) - TYPE(listItem), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array - INTEGER(mpl), INTENT(IN) :: length - CHARACTER (LEN=*), INTENT(IN) :: text - - INTEGER(mpi) :: ifail - ALLOCATE (array(length),stat=ifail) - CALL mpalloccheck(ifail,((mps+mpi)*length)/mpi,text) - END SUBROUTINE mpalloclist - - !> allocate (1D) character array - SUBROUTINE mpalloccvec(array,length,text) - CHARACTER, DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array - INTEGER(mpl), INTENT(IN) :: length - CHARACTER (LEN=*), INTENT(IN) :: text - - INTEGER(mpi) :: ifail - ALLOCATE (array(length),stat=ifail) - CALL mpalloccheck(ifail,(length+mpi-1)/mpi,text) - END SUBROUTINE mpalloccvec - - !> check allocation - SUBROUTINE mpalloccheck(ifail,numwords,text) - INTEGER(mpi), INTENT(IN) :: ifail - INTEGER(mpl), INTENT(IN) :: numwords - CHARACTER (LEN=*), INTENT(IN) :: text - IF (ifail == 0) THEN - nummpalloc=nummpalloc+1 - numwordsalloc = numwordsalloc + numwords - maxwordsalloc = MAX(maxwordsalloc, numwordsalloc) - IF (printflagalloc /= 0) THEN - print *, ' MPALLOC allocated ', numwords, ' words for : ', text - print *, ' words used ', numwordsalloc, maxwordsalloc - ENDIF - ELSE - print *, ' MPALLOC failed to allocate ', numwords, ' words for : ', text - print *, ' MPALLOC words used ', numwordsalloc, maxwordsalloc - print *, ' MPALLOC stat = ', ifail - CALL peend(30,'Aborted, memory allocation failed') - STOP - ENDIF - END SUBROUTINE mpalloccheck - ! deallocate dynamic vector or array - !> deallocate (1D) double precision array - SUBROUTINE mpdeallocdvec(array) - REAL(mpd), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array - - INTEGER(mpi) :: ifail - INTEGER(mpl) :: isize - isize = (mpd*size(array,kind=mpl))/mpi - DEALLOCATE (array,stat=ifail) - CALL mpdealloccheck(ifail,isize) - END SUBROUTINE mpdeallocdvec - - !> deallocate (1D) single precision array - SUBROUTINE mpdeallocfvec(array) - REAL(mps), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array - - INTEGER(mpi) :: ifail - INTEGER(mpl) :: isize - isize = (mps*size(array,kind=mpl))/mpi - DEALLOCATE (array,stat=ifail) - CALL mpdealloccheck(ifail,isize) - END SUBROUTINE mpdeallocfvec - - !> deallocate (1D) integer array - SUBROUTINE mpdeallocivec(array) - INTEGER(mpi), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array - - INTEGER(mpi) :: ifail - INTEGER(mpl) :: isize - isize = size(array,kind=mpl) - DEALLOCATE (array,stat=ifail) - CALL mpdealloccheck(ifail,isize) - END SUBROUTINE mpdeallocivec - - !> allocate (2D) single precision array - SUBROUTINE mpdeallocfarr(array) - REAL(mps), DIMENSION(:,:), INTENT(IN OUT), ALLOCATABLE :: array - - INTEGER(mpi) :: ifail - INTEGER(mpl) :: isize - isize = (mps*size(array,kind=mpl))/mpi - DEALLOCATE (array,stat=ifail) - CALL mpdealloccheck(ifail,isize) - END SUBROUTINE mpdeallocfarr - - !> allocate (2D) integer array - SUBROUTINE mpdeallociarr(array) - INTEGER(mpi), DIMENSION(:,:), INTENT(IN OUT), ALLOCATABLE :: array - - INTEGER(mpi) :: ifail - INTEGER(mpl) :: isize - isize = size(array,kind=mpl) - DEALLOCATE (array,stat=ifail) - CALL mpdealloccheck(ifail,isize) - END SUBROUTINE mpdeallociarr - - !> deallocate (2D) large integer array - SUBROUTINE mpdealloclarr(array) - INTEGER(mpl), DIMENSION(:,:), INTENT(IN OUT), ALLOCATABLE :: array - - INTEGER(mpi) :: ifail - INTEGER(mpl) :: isize - isize = (mpl*size(array,kind=mpl))/mpi - DEALLOCATE (array,stat=ifail) - CALL mpdealloccheck(ifail,isize) - END SUBROUTINE mpdealloclarr - - !> deallocate (1D) list item array - SUBROUTINE mpdealloclist(array) - TYPE(listItem), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array - - INTEGER(mpi) :: ifail - INTEGER(mpl) :: isize - isize = ((mpi+mps)*size(array,kind=mpl))/mpi - DEALLOCATE (array,stat=ifail) - CALL mpdealloccheck(ifail,isize) - END SUBROUTINE mpdealloclist - - !> deallocate (1D) character array - SUBROUTINE mpdealloccvec(array) - CHARACTER, DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array - - INTEGER(mpi) :: ifail - INTEGER(mpl) :: isize - isize = (size(array,kind=mpl)+mpi-1)/mpi - DEALLOCATE (array,stat=ifail) - CALL mpdealloccheck(ifail,isize) - END SUBROUTINE mpdealloccvec - - !> check deallocation - SUBROUTINE mpdealloccheck(ifail,numwords) - INTEGER(mpi), INTENT(IN) :: ifail - INTEGER(mpl), INTENT(IN) :: numwords - IF (ifail == 0) THEN - numwordsalloc = numwordsalloc - numwords - nummpdealloc=nummpdealloc+1 - IF (printflagalloc /= 0) THEN - print *, ' MPDEALLOC deallocated ', numwords, ' words ' - print *, ' words used ', numwordsalloc, maxwordsalloc - ENDIF - ELSE - print *, ' MPDEALLOC failed to deallocate ', numwords, ' words' - print *, ' MPDEALLOC words used ', numwordsalloc, maxwordsalloc - print *, ' MPDEALLOC stat = ', ifail - CALL peend(31,'Aborted, memory deallocation failed') - STOP - ENDIF - END SUBROUTINE mpdealloccheck - -END MODULE mpdalc diff --git a/millepede/mpdef.f90 b/millepede/mpdef.f90 deleted file mode 100644 index 26df0f5430..0000000000 --- a/millepede/mpdef.f90 +++ /dev/null @@ -1,44 +0,0 @@ -!> \file -!! Definitions. -!! -!! \author Claus Kleinwort, DESY, 2012 (Claus.Kleinwort@desy.de) -!! -!! \copyright -!! Copyright (c) 2012 - 2015 Deutsches Elektronen-Synchroton, -!! Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n -!! 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. \n\n -!! 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. \n\n -!! You should have received a copy of the GNU Library General Public -!! License along with this program (see the file COPYING.LIB for more -!! details); if not, write to the Free Software Foundation, Inc., -!! 675 Mass Ave, Cambridge, MA 02139, USA. -!! - -!> Definition of constants. -MODULE mpdef - IMPLICIT NONE - SAVE - ! precision constants - INTRINSIC :: selected_real_kind - INTRINSIC :: selected_int_kind - INTEGER, PARAMETER :: mpi4 = selected_int_kind(9) !> 4 byte integer - INTEGER, PARAMETER :: mpi8 = selected_int_kind(18) !> 8 byte integer - INTEGER, PARAMETER :: mpr4 = selected_real_kind(6, 37) !> 4 byte float - INTEGER, PARAMETER :: mpr8 = selected_real_kind(15, 307) !> 8 byte float - INTEGER, PARAMETER :: mpr16 = selected_real_kind(33, 4931) !> 16 byte float, gcc needs libquadmath INTEGER, PARAMETER :: mpi = selected_int_kind(9) !> 4 byte integer - INTEGER, PARAMETER :: mpi = mpi4 !> integer - INTEGER, PARAMETER :: mpl = mpi8 !> long integer - INTEGER, PARAMETER :: mps = mpr4 !> single precision - INTEGER, PARAMETER :: mpd = mpr8 !> double precision - !> list items from steering file - TYPE listItem - INTEGER(mpi) :: label - REAL(mpd) :: value - END TYPE listItem -END MODULE mpdef diff --git a/millepede/mphistab.f90 b/millepede/mphistab.f90 deleted file mode 100644 index 432e1d67bc..0000000000 --- a/millepede/mphistab.f90 +++ /dev/null @@ -1,1041 +0,0 @@ - -! Code converted using TO_F90 by Alan Miller -! Date: 2012-03-16 Time: 11:07:45 - -!> \file -!! Histogramming package. -!! -!! \author Volker Blobel, University Hamburg, 2005-2009 (initial Fortran77 version) -!! \author Claus Kleinwort, DESY (maintenance and developement) -!! -!! \copyright -!! Copyright (c) 2009 - 2015 Deutsches Elektronen-Synchroton, -!! Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n -!! 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. \n\n -!! 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. \n\n -!! You should have received a copy of the GNU Library General Public -!! License along with this program (see the file COPYING.LIB for more -!! details); if not, write to the Free Software Foundation, Inc., -!! 675 Mass Ave, Cambridge, MA 02139, USA. -!! -!!\verbatim -!! HMP... and GMP... -!! Histogram and XY data in text files -!! -!! Booking: -!! -!! CALL HMPDEF(IH,XA,XB,TEXT) CALL GMPDEF(IG,ITYP,TEXT) -!! where where -!! IH = 1 ... 10 IG = 1 ... 10 -!! XA,XB = left, right limit ITYP = 1 dots -!! TEXT = explanation = 2 line -!! = 3 dots and line -!! = 4 symbols -!! = 5 mean/sigma -!! TEXT = explanation -!! -!! CALL HMPLUN(LUNW) CALL GMPLUN(LUNW) -!! unit for output unit for output -!! -!! CALL HMPENT(IH,X) CALL GMPXY(IG,X,Y) -!! entry flt.pt. X add (X,Y) pair -!! -!! CALL GMPXYD(IG,X,Y,DX,DY) -!! add (X,Y,DX,DY) ITYP=4 -!! -!! new CALL GMPMS(IG,X,Y) -!! mean/sigma from x,y -!! -!! Booking log integer histogram: -!! -!! CALL HMPLDF(IH,TEXT) -!! book and reset log integer histogram -!! -!! CALL HMPLNT(IH,IX) -!! entry integer IX -!! -!! Printing and writing: -!! -!! CALL HMPRNT(IH) CALL GMPRNT(IG) -!! print histogram IH or all, if 0 print data Ig or all, if 0 -!! -!! CALL HMPWRT(IH) CALL GMPWRT(IG) -!! write histogram IH or all to file write data IG or all to file -!! -!! -!! Storage manager for GMP... -!! -!! CALL STMARS !! init/reset storage manager -!! -!! CALL STMAPR(JFLC,X,Y) !! store pair (X,Y) -!! -!! CALL STMADP(JFLC,FOUR) !! store double pair -!! -!! CALL STMACP(JFLC,ARRAY,N) !! copy (cp) all pairs to array -!! -!! CALL STMARM(JFLC) !! remove (rm) stored paiirs -!! -!!\endverbatim -!! -!! The number of histograms is limited to NUMHIS (=15), the number of XY data plots -!! to NUMGXY (=10) and the storage of XY points to NDIM (=5000). As each XY plot can -!! contain up to NLIMIT (=500) points (before averaging) NDIM should be NLIMIT*NUMGXY. - -! *************************** Histograms ****************************** - -SUBROUTINE hmpdef(ih,xa,xb,text) ! book, reset histogram - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: iha - INTEGER(mpi) :: ihb - INTEGER(mpi) :: ihc - INTEGER(mpi) :: ix - INTEGER(mpi) :: j - INTEGER(mpi) :: lun - INTEGER(mpi) :: lunw - INTEGER(mpi) :: nbin - INTEGER(mpi) :: nn - REAL(mps) :: x - REAL(mps) :: xcent - REAL(mps) :: xmean - REAL(mps) :: xsigm - ! book millepede histogram, 120 bins - - INTEGER(mpi), INTENT(IN) :: ih - REAL(mps), INTENT(IN) :: xa - REAL(mps), INTENT(IN) :: xb - CHARACTER (LEN=*), INTENT(IN) :: text - INTEGER(mpi), PARAMETER :: numhis=15 - INTEGER(mpi) :: inhist(120,numhis) - INTEGER(mpi) ::jnhist(5,numhis) - INTEGER(mpi) ::khist(numhis) - REAL(mps) :: fnhist(120,numhis) - EQUIVALENCE (inhist(1,1),fnhist(1,1)) - INTEGER(mpi) :: kvers(numhis) - REAL(mps) :: xl(6,numhis) - REAL(mpd):: dl(2,numhis) - CHARACTER (LEN=60):: htext(numhis) - SAVE - DATA khist/numhis*0/,lun/7/ - ! ... - IF(ih <= 0.OR.ih > numhis) RETURN - ! IF(XA.EQ.XB) RETURN - DO i=1,120 - inhist(i,ih)=0 - END DO - DO j=1,5 - jnhist(j,ih)=0 - END DO - xl(1,ih)=xa - xl(2,ih)=xb - xl(3,ih)=0.0 - IF(xa /= xb) xl(3,ih)=120.0/(xb-xa) - xl(6,ih)=0.5*(xa+xb) ! center - IF(khist(ih) == 0) THEN - kvers(ih)=0 - ELSE - kvers(ih)=kvers(ih)+1 - END IF - khist(ih)=1 ! flt.pt. (lin) - htext(ih)=text - dl(1,ih)=0.0_mpd - dl(2,ih)=0.0_mpd - RETURN - - ENTRY hmpldf(ih,text) ! book, reset log histogram - IF(ih <= 0.OR.ih > numhis) RETURN - DO i=1,120 - inhist(i,ih)=0 - END DO - DO j=1,5 - jnhist(j,ih)=0 - END DO - IF(khist(ih) == 0) THEN - kvers(ih)=0 - ELSE - kvers(ih)=kvers(ih)+1 - END IF - khist(ih)=2 ! integer log - htext(ih)=text - xl(1,ih)=0.0 - xl(2,ih)=6.0 - RETURN - - ENTRY hmpent(ih,x) ! entry flt.pt. - IF(ih <= 0.OR.ih > numhis) RETURN - IF(khist(ih) /= 1) RETURN - IF(jnhist(4,ih) >= 2147483647) RETURN - jnhist(4,ih)=jnhist(4,ih)+1 ! count - IF(jnhist(4,ih) <= 120) THEN - fnhist(jnhist(4,ih),ih)=x ! store value - IF(jnhist(4,ih) == 120) THEN - CALL hmpmak(inhist(1,ih),fnhist(1,ih),jnhist(1,ih), xl(1,ih),dl(1,ih)) - END IF - RETURN - END IF - ! IF(JNHIST(1,IH)+JNHIST(2,IH)+JNHIST(3,IH).EQ.0) THEN - ! XL(4,IH)=X - ! XL(5,IH)=X - ! END IF - i=INT(1.0+xl(3,ih)*(x-xl(1,ih)),mpi) ! X - Xmin - j=2 - IF(i < 1) j=1 - IF(i > 120) j=3 - jnhist(j,ih)=jnhist(j,ih)+1 - xl(4,ih)=MIN(xl(4,ih),x) - xl(5,ih)=MAX(xl(5,ih),x) - IF(j /= 2) RETURN - inhist(i,ih)=inhist(i,ih)+1 - dl(1,ih)=dl(1,ih)+ x-xl(6,ih) - dl(2,ih)=dl(2,ih)+(x-xl(6,ih))**2 - RETURN - - ENTRY hmplnt(ih,ix) ! entry integer - IF(ih <= 0.OR.ih > numhis) RETURN - IF(khist(ih) /= 2) RETURN - IF(jnhist(1,ih) >= 2147483647) RETURN - IF(ix <= 0) THEN - jnhist(1,ih)=jnhist(1,ih)+1 - ELSE - IF(jnhist(4,ih) == 0) jnhist(4,ih)=ix - IF(jnhist(5,ih) == 0) jnhist(5,ih)=ix - jnhist(4,ih)=MIN(jnhist(4,ih),ix) - jnhist(5,ih)=MAX(jnhist(5,ih),ix) - i=INT(1.0+20.0*LOG10(REAL(ix,mps)),mpi) - j=2 - IF(i < 1) j=1 - IF(i > 120) j=3 - IF(j == 2) inhist(i,ih)=inhist(i,ih)+1 - jnhist(j,ih)=jnhist(j,ih)+1 - END IF - RETURN - - ENTRY hmprnt(ih) ! print, content vert - IF(ih == 0) THEN - iha=1 - ihb=numhis - ELSE - IF(ih <= 0.OR.ih > numhis) RETURN - iha=ih - ihb=ih - END IF - DO ihc=iha,ihb - IF(khist(ihc) /= 0) THEN - IF(khist(ihc) == 1) THEN - CALL hmpmak(inhist(1,ihc),fnhist(1,ihc),jnhist(1,ihc), & - xl(1,ihc),dl(1,ihc)) - END IF - nn=jnhist(1,ihc)+jnhist(2,ihc)+jnhist(3,ihc) - IF(nn /= 0.OR.khist(ihc) == 3) THEN - WRITE(*,111) -111 FORMAT(' ______',2('______________________________')) - IF(kvers(ihc) == 1) THEN - WRITE(*,*) 'Histogram',ihc,': ',htext(ihc) - ELSE - WRITE(*,*) 'Histogram',ihc,'/',kvers(ihc),': ',htext(ihc) - END IF - IF(khist(ihc) == 1) THEN - WRITE(*,*) ' Out_low inside out_high = ', (jnhist(j,ihc),j=1,3) - ELSE IF(khist(ihc) == 2) THEN - WRITE(*,*) ' 0_or_negative inside above_10^6 = ', & - (jnhist(j,ihc),j=1,3) - END IF - IF(khist(ihc) == 3) THEN - CALL pfvert(120,fnhist(1,ihc)) - END IF - IF(jnhist(2,ihc) /= 0) THEN ! integer content - CALL pivert(120,inhist(1,ihc)) - IF(khist(ihc) == 1) THEN - CALL psvert(xl(1,ihc),xl(2,ihc)) - ELSE IF(khist(ihc) == 2) THEN - CALL psvert(0.0,6.0) - END IF - END IF - IF(khist(ihc) == 1) THEN - WRITE(*,*) ' Min and Max are',xl(4,ihc),xl(5,ihc) - IF(jnhist(2,ihc) > 1) THEN - xmean=REAL(xl(6,ihc)+dl(1,ihc)/REAL(jnhist(2,ihc),mps),mps) - xcent=0.5*(xl(1,ihc)+xl(2,ihc)) - xsigm=REAL((dl(2,ihc)-dl(1,ihc)**2/REAL(jnhist(2,ihc),mps)),mps) - xsigm=SQRT(xsigm/REAL(jnhist(2,ihc)-1,mps)) - WRITE(*,*) ' Mean and sigma are', xmean,' +-',xsigm - END IF - ELSE IF(khist(ihc) == 2) THEN - WRITE(*,*) ' Plot of log10 of entries. Min and Max are', & - jnhist(4,ihc),jnhist(5,ihc) - END IF - END IF - END IF - END DO - RETURN - - ENTRY hmplun(lunw) ! unit for output - lun=lunw - RETURN - - ENTRY hmpwrt(ih) ! write histogram text file - IF(lun <= 0) RETURN - IF(ih == 0) THEN - iha=1 - ihb=numhis - ELSE - IF(ih <= 0.OR.ih > numhis) RETURN - iha=ih - ihb=ih - END IF - - DO ihc=iha,ihb ! histogram loop - IF(khist(ihc) /= 0) THEN - IF(khist(ihc) == 1) THEN - CALL hmpmak(inhist(1,ihc),fnhist(1,ihc),jnhist(1,ihc), & - xl(1,ihc),dl(1,ihc)) - END IF - nbin=120 - WRITE(lun,204) ' ' - WRITE(lun,201) ihc,kvers(ihc),khist(ihc) - WRITE(lun,204) htext(ihc) - IF (jnhist(1,ihc)+jnhist(2,ihc)+jnhist(3,ihc) == 0 & - .AND.xl(1,ihc) == xl(2,ihc)) THEN - ! hist is empty and hist range makes no sense - ! - cause: hist with 'variable edges' was never filled - ! - workaround: make lower and upper edge of hist differ in output - WRITE(lun,202) nbin,xl(1,ihc)-0.001,xl(2,ihc)+0.001 - ELSE - WRITE(lun,202) nbin,xl(1,ihc),xl(2,ihc) - END IF - WRITE(lun,203) (jnhist(j,ihc),j=1,3) - WRITE(lun,204) 'bincontent' - IF(khist(ihc) == 1.OR.khist(ihc) == 2) THEN - CALL kprint(lun,inhist(1,ihc),nbin) - ELSE - WRITE(lun,219) (fnhist(i,ihc),i=1,nbin) - END IF - - IF(khist(ihc) == 1) THEN - WRITE(lun,205) xl(4,ihc),xl(5,ihc) - ELSE IF(khist(ihc) == 2) THEN - WRITE(lun,205) REAL(jnhist(4,ihc),mps),REAL(jnhist(5,ihc),mps) - END IF - IF(khist(ihc) == 1) THEN - IF(jnhist(2,ihc) > 1) THEN - xmean=REAL(xl(6,ihc)+dl(1,ihc)/REAL(jnhist(2,ihc),mps),mps) - xcent=0.5*(xl(1,ihc)+xl(2,ihc)) - xsigm=REAL((dl(2,ihc)-dl(1,ihc)**2/REAL(jnhist(2,ihc),mps)),mps) - xsigm=SQRT(xsigm/REAL(jnhist(2,ihc)-1,mps)) - WRITE(lun,206) xmean,xsigm - END IF - END IF - WRITE(lun,204) 'end of histogram' - END IF - END DO - -201 FORMAT('Histogram ',i4,10X,'version ',i4,10X,'type',i2) -202 FORMAT(10X,' bins, limits ',i4,2G15.5) -203 FORMAT(10X,'out-low inside out-high ',3I10) -204 FORMAT(a) -205 FORMAT('minmax',2E15.7) -206 FORMAT('meansigma',2E15.7) - -219 FORMAT(4E15.7) -END SUBROUTINE hmpdef - -SUBROUTINE hmpmak(inhist,fnhist,jnhist,xl,dl) ! hist scale from data - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: k - INTEGER(mpi) :: nn - REAL(mps) :: x - REAL(mps) :: xa - REAL(mps) :: xb - - INTEGER(mpi), INTENT(OUT) :: inhist(120) - REAL(mps), INTENT(IN) :: fnhist(120) - INTEGER(mpi), INTENT(IN OUT) :: jnhist(5) - REAL(mps), INTENT(IN OUT) :: xl(6) - REAL(mpd), INTENT(OUT) :: dl(2) - REAL(mps) :: cphist(120) - - - - SAVE - ! ... - nn=jnhist(4) - ! WRITE(*,*) 'HMPMAK: NN,JNHIST(5)',NN,JNHIST(5) - IF(nn == 0.OR.jnhist(5) /= 0) RETURN - jnhist(5)=1 - DO i=1,nn - ! WRITE(*,*) 'copy ',I,FNHIST(I) - cphist(i)=fnhist(i) - END DO - CALL heapf(cphist,nn) - IF(xl(3) == 0.0) THEN - CALL bintab(cphist,nn,xa,xb) - xl(1)=xa - xl(2)=xb - xl(3)=0.0 - IF(xa /= xb) xl(3)=120.0/(xb-xa) - xl(6)=0.5*(xa+xb) ! center - END IF - xl(4)=cphist( 1) - xl(5)=cphist(nn) - ! WRITE(*,*) 'XL ',XL - DO i=1,nn - inhist(i)=0 - END DO - DO k=1,nn - x=cphist(k) - i=INT(1.0+xl(3)*(x-xl(1)),mpi) ! X - Xmin - ! WRITE(*,*) 'K,I,X ',K,I,X - j=2 - IF(i < 1) j=1 - IF(i > 120) j=3 - jnhist(j)=jnhist(j)+1 - IF(j == 2) THEN - inhist(i)=inhist(i)+1 - dl(1)=dl(1)+ x-xl(6) - dl(2)=dl(2)+(x-xl(6))**2 - END IF - END DO -END SUBROUTINE hmpmak - - - - -SUBROUTINE bintab(tab,n,xa,xb) ! hist scale from data - USE mpdef - - IMPLICIT NONE - REAL(mps) :: dd - REAL(mps) :: dx - INTEGER(mpi) :: i - INTEGER(mpi) :: iexp - INTEGER(mpi) :: ii - INTEGER(mpi) :: j - INTEGER(mpi) :: m1 - INTEGER(mpi) :: m2 - INTEGER(mpi) :: n1 - INTEGER(mpi) :: n2 - REAL(mps) :: rat - REAL(mps) :: x1 - REAL(mps) :: x2 - REAL(mps) :: xx - ! Bin limits XA and XB from TAB(N) - - REAL(mps), INTENT(IN) :: tab(n) - INTEGER(mpi), INTENT(IN) :: n - REAL(mps), INTENT(OUT) :: xa - REAL(mps), INTENT(OUT) :: xb - - REAL(mps) :: bin(10) - DATA bin/1.0,1.5,2.0,3.0,4.0,5.0,8.0,10.0,15.0,20.0/ - SAVE - ! ... - - CALL heapf(tab,n) ! reduced statistic - ! WRITE(*,*) ' ' - ! WRITE(*,*) 'Sorted ',(TAB(I),I=1,N) - IF(n < 100) THEN - x1=tab(1) - x2=tab(n) - ! WRITE(*,*) 'reduced statistic X1 X2 ',X1,X2 - ELSE ! large statistic - m1=INT(1.0+0.05*REAL(n),mpi) - m2=INT(1.0+0.16*REAL(n),mpi) - x1=tab(m1)-4.0*(tab(m2)-tab(m1)) - IF(x1 < 0.0.AND.tab(1) >= 0.0) x1=tab(1) - x2=tab(n+1-m1)+4.0*(tab(n+1-m1)-tab(n+1-m2)) - IF(x2 > 0.0.AND.tab(n) <= 0.0) x2=tab(n) - ! WRITE(*,*) 'large statistic ',X1,X2 - ! WRITE(*,*) 'min und max ',TAB(1),TAB(N) - IF(x1*tab(1) <= 0.0) x1=0.0 - IF(x2*tab(n) <= 0.0) x2=0.0 - ! WRITE(*,*) 'large statistic zero ',X1,X2 - IF(x1*x2 < 0.0.AND.MIN(-x1,x2) > 0.6*MAX(-x1,x2)) THEN - xx=MAX(-x1,x2) ! symmetry - x1=-xx - x2=+xx - ELSE IF(x1*x2 > 0.0.AND. & ! include zero ? - ABS(MIN(x1,x2)) < 0.4*ABS(MAX(x1,x2))) THEN - IF(x1 < 0.0) THEN - x2=0.0 - ELSE - x1=0.0 - END IF - END IF - ! WRITE(*,*) 'large statistic ',X1,X2 - END IF - IF(x1 == x2) THEN - x1=x1-1.0 - x2=x2+1.0 - END IF - dx=x2-x1 - ! WRITE(*,*) 'X1,X2,DX ',X1,X2,DX - rat=0.0 - ii=1 - DO j=1,11 - i=j - IF(j == 11) i=ii - iexp=INT(101.0+LOG10(dx)-LOG10(6.0*bin(i)),mpi) - iexp=iexp-100 - dd=bin(i)*10.0**iexp - - n1=INT(ABS(x1)/dd,mpi) - IF(x1 < 0.0) n1=-n1 - IF(REAL(n1,mps)*dd > x1) n1=n1-1 - ! WRITE(*,*) 'Bin ',I,N1,N1*DD,X1 - - n2=INT(ABS(x2)/dd,mpi) - IF(x2 < 0.0) n2=-n2 - IF(REAL(n2,mps)*dd < x2) n2=n2+1 - ! WRITE(*,*) 'Bin ',I,N2,N2*DD,X2 -10 IF(n2-n1 < 6) THEN - IF(n1 /= 0) n1=n1-1 - IF(n2-n1 < 6.AND.n2 /= 0) n2=n2+1 - GO TO 10 - END IF - ! WRITE(*,*) 'corrected N1 N2 ',N1,N2 - xa=SIGN(REAL(n1,mps)*dd,x1) - xb=SIGN(REAL(n2,mps)*dd,x2) - ! WRITE(*,*) J,' resulting limits XA XB ',XA,XB - IF((x2-x1)/(xb-xa) > rat) THEN - ii=i - rat=(x2-x1)/(xb-xa) - END IF - END DO -! WRITE(*,*) J,' resulting limits XA XB ',XA,XB -END SUBROUTINE bintab - -SUBROUTINE kprint(lun,list,n) ! print integer array - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ia - INTEGER(mpi) :: ib - INTEGER(mpi) :: k - INTEGER(mpi) :: ln - INTEGER(mpi) :: lp - INTEGER(mpi) :: np - ! print integer array LIST(N) - - INTEGER(mpi), INTENT(IN OUT) :: lun - INTEGER(mpi), INTENT(IN) :: list(n) - INTEGER(mpi), INTENT(IN) :: n - INTEGER(mpi) :: li(7) - DATA li/2,3,4,6,8,9,12/ ! number of characters - SAVE - ! ... - ib=0 -10 ia=ib+1 - IF(ia > n) RETURN - DO k=1,7 - np=72/li(k) - ib=MIN(ia-1+np,n) - IF(k <= 6) THEN - lp=10**(li(k)-1)-1 ! maximum positive - ln=-lp/10 ! minimum negative - DO i=ia,ib - IF(list(i) > lp.OR.list(i) < ln) GO TO 20 - END DO - END IF - IF(k == 1) THEN - WRITE(lun,101) (list(i),i=ia,ib) - ELSE IF(k == 2) THEN - WRITE(lun,102) (list(i),i=ia,ib) - ELSE IF(k == 3) THEN - WRITE(lun,103) (list(i),i=ia,ib) - ELSE IF(k == 4) THEN - WRITE(lun,104) (list(i),i=ia,ib) - ELSE IF(k == 5) THEN - WRITE(lun,105) (list(i),i=ia,ib) - ELSE IF(k == 6) THEN - WRITE(lun,106) (list(i),i=ia,ib) - ELSE IF(k == 7) THEN - WRITE(lun,107) (list(i),i=ia,ib) - END IF - GO TO 10 -20 CONTINUE - END DO -101 FORMAT(36I2) -102 FORMAT(24I3) -103 FORMAT(18I4) -104 FORMAT(12I6) -105 FORMAT( 9I8) -106 FORMAT( 8I9) -107 FORMAT( 6I12) -END SUBROUTINE kprint - -! ***************************** XY data **************************** - -SUBROUTINE gmpdef(ig,ityp,text) ! book, reset XY storage - USE mpdef - - IMPLICIT NONE - REAL(mps) :: dx - REAL(mps) :: dy - INTEGER(mpi) :: i - INTEGER(mpi) :: iga - INTEGER(mpi) :: igb - INTEGER(mpi) :: igc - INTEGER(mpi) :: j - INTEGER(mpi) :: lun - INTEGER(mpi) :: lunw - INTEGER(mpi) :: n - INTEGER(mpi) :: na - REAL(mps) :: wght - REAL(mps) :: x - REAL(mps) :: y - REAL(mps) :: y1 - ! ITYP = 1 X,Y as dots - ! = 2 X,Y as line - ! = 3 X,Y as line and dots - ! = 4 X,Y, DX,DY symbols - - INTEGER(mpi), INTENT(IN) :: ig - INTEGER(mpi), INTENT(IN) :: ityp - CHARACTER (LEN=*), INTENT(IN) :: text - INTEGER(mpi), PARAMETER :: narr=1000 - REAL(mps) :: array(2,narr) - REAL(mps) ::array4(4,narr/2) - REAL(mps) ::array1(narr+narr) - REAL(mps) ::four(4) - EQUIVALENCE (array(1,1),array4(1,1),array1(1)) - INTEGER(mpi), PARAMETER :: numgxy=10 - INTEGER(mpi), PARAMETER :: nlimit=500 - INTEGER(mpi) :: nstr(numgxy) - INTEGER(mpi) ::igtp(numgxy) - INTEGER(mpi) ::lvers(numgxy) - INTEGER(mpi) ::nst(3,numgxy) - REAL(mps) :: xyplws(10,numgxy) - INTEGER(mpi) :: jflc(5,numgxy) - INTEGER(mpi) ::kflc(5,numgxy) - ! JFLC(1,.) = first used index - ! JFLC(2,.) = last used index - ! JFLC(3,.) = counter of used places - ! JFLC(4,.) = counter of ignored - ! JFLC(5,.) = limit for JFLC(3) - CHARACTER (LEN=60):: gtext(numgxy) - - LOGICAL:: start - SAVE - DATA start/.TRUE./,lun/7/ - DATA nstr/numgxy*0/ ! by GF - ! ... - IF(start) THEN - start=.FALSE. - CALL stmars ! initialize storage - DO i=1,numgxy - DO j=1,5 - jflc(j,i)=0 - kflc(j,i)=0 - END DO - END DO - END IF - - IF(ig < 1.OR.ig > numgxy) RETURN - IF(ityp < 1.OR.ityp > 5) RETURN - IF(nstr(ig) == 0) THEN - lvers(ig)=0 - ELSE - lvers(ig)=lvers(ig)+1 - END IF - nstr(ig)=1 ! by GF - ! remove stored elements - IF(jflc(1,ig) /= 0) CALL stmarm(jflc(1,ig)) - IF(kflc(1,ig) /= 0) CALL stmarm(kflc(1,ig)) - igtp(ig)=ityp - gtext(ig)=text - DO j=1,5 - jflc(j,ig)=0 - END DO - jflc(5,ig)=nlimit - IF(ityp == 5) THEN - DO j=1,5 - kflc(j,ig)=0 - END DO - jflc(5,ig)=128 ! maximum of 128 values - kflc(5,ig)=narr - nst(1,ig)=0 - nst(2,ig)=0 - nst(3,ig)=1 - DO j=1,10 - xyplws(j,ig)=0.0 - END DO - END IF - RETURN - - ENTRY gmpxy(ig,x,y) ! add (X,Y) pair - IF(ig < 1.OR.ig > numgxy) RETURN ! check argument IG - IF(igtp(ig) < 1.OR.igtp(ig) > 3) RETURN ! check type - CALL stmapr(jflc(1,ig),x,y) - RETURN - - ENTRY gmpxyd(ig,x,y,dx,dy) ! add (X,Y,DX,DY) - IF(ig < 1.OR.ig > numgxy) RETURN ! check argument IG - IF(igtp(ig) /= 4) RETURN - four(1)=x - four(2)=y - four(3)=dx - four(4)=dy - CALL stmadp(jflc(1,ig),four) - RETURN - - ENTRY gmpms(ig,x,y) ! mean sigma(X) from Y - ! mean sigma from Y, as a function of X - ! WRITE(*,*) 'GMPMS ',IG,X,Y - - IF(ig < 1.OR.ig > numgxy) RETURN ! check argument IG - IF(igtp(ig) /= 5) RETURN - - xyplws(10,ig)=x ! last X coordinate - IF(nst(1,ig) == 0) THEN - y1=y - nst(1,ig)=1 - IF(kflc(3,ig) == 0) xyplws(9,ig)=x ! start coordinate - ELSE - nst(1,ig)=0 - CALL stmapr(kflc(1,ig),y1,y) ! store pair - IF(kflc(3,ig) >= kflc(5,ig)) THEN - CALL stmacp(kflc(1,ig),array,n) ! get data - CALL stmarm(kflc(1,ig)) ! remove data - n=n+n - CALL rmesig(array,n,xyplws(2,ig),xyplws(4,ig)) - nst(2,ig)=nst(2,ig)+1 - IF(nst(2,ig) == 1) xyplws(7,ig)=xyplws(9,ig) - xyplws(8,ig)=x ! end coordinate - xyplws(5,ig)=xyplws(5,ig)+xyplws(2,ig) - xyplws(6,ig)=xyplws(6,ig)+xyplws(4,ig) - IF(nst(2,ig) == nst(3,ig)) THEN - xyplws(1,ig)=0.5*(xyplws(7,ig)+xyplws(8,ig)) - xyplws(2,ig)=xyplws(5,ig)/REAL(nst(3,ig),mps) - xyplws(3,ig)=0.5*(xyplws(8,ig)-xyplws(7,ig)) - xyplws(4,ig)=xyplws(6,ig)/REAL(nst(3,ig),mps) - xyplws(5,ig)=0.0 - xyplws(6,ig)=0.0 - nst(2,ig)=0 - CALL stmadp(jflc(1,ig),xyplws(1,ig)) - IF(jflc(3,ig) >= jflc(5,ig)) THEN - CALL stmacp(jflc(1,ig),array4,n) ! get data - n=n/2 - CALL stmarm(jflc(1,ig)) ! remove data - DO i=1,n,2 ! average - xyplws(7,ig)=array4(1,i )-array4(3, i) - xyplws(8,ig)=array4(1,i+1)+array4(3,i+1) - xyplws(1,ig)=0.5*(xyplws(7,ig)+xyplws(8,ig)) - xyplws(2,ig)=0.5*(array4(2,i)+array4(2,i+1)) - xyplws(3,ig)=0.5*(xyplws(8,ig)-xyplws(7,ig)) - xyplws(4,ig)=0.5*(array4(4,i)+array4(4,i+1)) - CALL stmadp(jflc(1,ig),xyplws(1,ig)) - END DO - nst(3,ig)=nst(3,ig)+nst(3,ig) - END IF - END IF - END IF - END IF - RETURN - - ENTRY gmprnt(ig) ! print XY data - IF(ig == 0) THEN - iga=1 - igb=numgxy - ELSE - IF(ig <= 0.OR.ig > numgxy) RETURN - iga=ig - igb=ig - END IF - DO igc=iga,igb - - IF(igtp(igc) >= 1.AND.igtp(igc) <= 3) THEN - WRITE(*,*) ' ' - WRITE(*,*) 'Store ',igc,': ',gtext(igc) - IF(jflc(4,igc) == 0) THEN - WRITE(*,*) ' stored n-tuples: ',jflc(3,igc) - ELSE - WRITE(*,*) ' stored n-tuples, not-stored n-tuples: ', & - jflc(3,igc),', ',jflc(4,igc) - END IF - - CALL stmacp(jflc(1,igc),array,na) ! get all data - - DO n=1,na - WRITE(*,102) n, array(1,n),array(2,n) - END DO - - ELSE IF(igtp(igc) == 4) THEN - - WRITE(*,*) ' ' - WRITE(*,*) 'Store ',igc,': ',gtext(igc) - IF(jflc(4,igc) == 0) THEN - WRITE(*,*) ' stored n-tuples: ',jflc(3,igc) - ELSE - WRITE(*,*) ' stored n-tuples, not-stored n-tuples: ', & - jflc(3,igc),', ',jflc(4,igc) - END IF - - CALL stmacp(jflc(1,igc),array,na) ! get all data - na=na/2 - - DO n=1,na - WRITE(*,102) n,(array4(j,n),j=1,4) - END DO - - ELSE IF(igtp(igc) == 5) THEN - - CALL stmacp(kflc(1,igc),array,n) ! get data - CALL stmarm(kflc(1,igc)) ! remove data - n=n+n - IF(nst(1,igc) == 1) THEN - n=n+1 - array1(n)=y1 - nst(1,igc)=0 ! reset - END IF - IF(n /= 0) THEN - xyplws(7,igc)=xyplws( 9,igc) - xyplws(8,igc)=xyplws(10,igc) - CALL rmesig(array1,n,xyplws(2,igc),xyplws(4,igc)) - wght=REAL(n,mps)/REAL(nst(3,igc)*kflc(5,igc),mps) - xyplws(5,igc)=xyplws(5,igc)+xyplws(2,igc)*wght - xyplws(6,igc)=xyplws(6,igc)+xyplws(4,igc)*wght - xyplws(2,igc)=xyplws(5,igc)/(REAL(nst(2,igc),mps)+wght) - xyplws(4,igc)=xyplws(6,igc)/(REAL(nst(2,igc),mps)+wght) - xyplws(1,igc)=0.5*(xyplws(7,igc)+xyplws(8,igc)) - xyplws(3,igc)=0.5*(xyplws(8,igc)-xyplws(7,igc)) - CALL stmadp(jflc(1,igc),xyplws(1,igc)) - END IF - - WRITE(*,*) ' ' - WRITE(*,*) 'Store ',igc,': ',gtext(igc) - IF(jflc(4,igc) == 0) THEN - WRITE(*,*) ' stored n-tuples: ',jflc(3,igc) - ELSE - WRITE(*,*) ' stored n-tuples, not-stored n-tuples: ', & - jflc(3,igc),', ',jflc(4,igc) - END IF - - CALL stmacp(jflc(1,igc),array,na) ! get all data - na=na/2 - DO n=1,na - WRITE(*,102) n,(array4(j,n),j=1,4) - END DO - END IF - END DO - RETURN - - ENTRY gmplun(lunw) ! unit for output - lun=lunw - RETURN - - ENTRY gmpwrt(ig) ! write XY text file - IF(lun <= 0) RETURN - IF(ig == 0) THEN - iga=1 - igb=numgxy - ELSE - IF(ig <= 0.OR.ig > numgxy) RETURN - iga=ig - igb=ig - END IF - DO igc=iga,igb - IF(igtp(igc) == 5) THEN - - CALL stmacp(kflc(1,igc),array,n) ! get data - CALL stmarm(kflc(1,igc)) ! remove data - n=n+n - IF(nst(1,igc) == 1) THEN - n=n+1 - array1(n)=y1 - nst(1,igc)=0 ! reset - END IF - IF(n /= 0) THEN - xyplws(7,igc)=xyplws( 9,igc) - xyplws(8,igc)=xyplws(10,igc) - CALL rmesig(array1,n,xyplws(2,igc),xyplws(4,igc)) - wght=REAL(n,mps)/REAL(nst(3,igc)*kflc(5,igc),mps) - xyplws(5,igc)=xyplws(5,igc)+xyplws(2,igc)*wght - xyplws(6,igc)=xyplws(6,igc)+xyplws(4,igc)*wght - xyplws(2,igc)=xyplws(5,igc)/(REAL(nst(2,igc),mps)+wght) - xyplws(4,igc)=xyplws(6,igc)/(REAL(nst(2,igc),mps)+wght) - xyplws(1,igc)=0.5*(xyplws(7,igc)+xyplws(8,igc)) - xyplws(3,igc)=0.5*(xyplws(8,igc)-xyplws(7,igc)) - CALL stmadp(jflc(1,igc),xyplws(1,igc)) - END IF - - END IF - IF(jflc(3,igc)+jflc(4,igc) /= 0) THEN - WRITE(lun,204) ' ' - WRITE(lun,201) igc,lvers(igc),igtp(igc) - WRITE(lun,204) gtext(igc) - WRITE(lun,203) jflc(3,igc)+jflc(4,igc) - CALL stmacp(jflc(1,igc),array,na) ! get all data - IF(igtp(igc) >= 1.AND.igtp(igc) <= 3) THEN - WRITE(lun,204) 'x-y' - DO n=1,na - WRITE(lun,205) array(1,n),array(2,n) - END DO - ELSE IF(igtp(igc) == 4.OR.igtp(igc) == 5) THEN - WRITE(lun,204) 'x-y-dx-dy' - na=na/2 - DO n=1,na - WRITE(lun,205) (array4(j,n),j=1,4) - END DO - END IF - WRITE(lun,204) 'end of xy-data' - END IF - END DO -102 FORMAT(i12,4G15.7) - ! 103 FORMAT(' Index ___X___ ___Y___ '/ - ! + ' ----- -------------- --------------') - ! 104 FORMAT(' Index ___X___ ___Y___ ', - ! + ' ___DX__ ___DY__ '/ - ! + ' ----- -------------- --------------', - ! + ' -------------- --------------') -201 FORMAT('XY-Data ',i4,10X,'version ',i4,10X,'type',i2) -203 FORMAT(10X,'stored not-stored ',2I10) -204 FORMAT(a) -205 FORMAT(3X,4G15.7) -END SUBROUTINE gmpdef - - -SUBROUTINE stmars ! init/reset storage - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ifre - INTEGER(mpi) :: ifrea - INTEGER(mpi) :: ifreb - INTEGER(mpi) :: ind - INTEGER(mpi) :: j - INTEGER(mpi) :: n - REAL(mps) :: x - REAL(mps) :: y - INTEGER(mpi), PARAMETER :: ndim=5000 ! storage dimension, should be NUMGXY*NLIMIT - REAL(mps) :: tk(2,ndim) ! pair storage for data pairs - INTEGER(mpi) :: next(ndim) ! pointer - INTEGER(mpi) :: iflc1 ! first and last index of free pairs - INTEGER(mpi) ::iflc2 ! first and last index of free pairs - SAVE - - REAL(mps) :: four(4) ! double_pair, copy array - REAL(mps) ::array(2,*) ! double_pair, copy array - INTEGER(mpi) :: jflc(5) ! user array - ! JFLC(1) = first used index - ! JFLC(2) = last used index - ! JFLC(3) = counter of used places - ! JFLC(4) = counter of ignored - ! JFLC(5) = limit for JFLC(3) - ! ... - DO i=1,ndim - next(i)=i+1 ! pointer to next free location - tk(1,i)=0.0 ! reset - tk(2,i)=0.0 - END DO - next(ndim)=0 ! ... and end pointer - iflc1=1 ! index first free pair - iflc2=ndim ! index last free pair - RETURN - - ENTRY stmapr(jflc,x,y) ! store pair (X,Y) - ifre=iflc1 ! index of free place - IF(ifre == 0.OR.jflc(3) >= jflc(5)) THEN ! overflow - jflc(4)=jflc(4)+1 - ELSE - iflc1=next(ifre) ! pointer to new free location - IF(jflc(1) == 0) THEN ! first item - jflc(1)=ifre - ELSE - next(jflc(2))=ifre - END IF - next(ifre)=0 - jflc(2)=ifre ! last index - jflc(3)=jflc(3)+1 ! counter - tk(1,ifre)=x - tk(2,ifre)=y - END IF - RETURN - - ENTRY stmadp(jflc,four) ! store double pair - ifrea=iflc1 ! index of 1. free place - IF(ifrea == 0) THEN ! overflow - jflc(4)=jflc(4)+1 - ELSE - ifreb=next(iflc1) ! index of 2. free place - IF(ifreb == 0.OR.jflc(3) >= 2*jflc(5)) THEN ! overflow - jflc(4)=jflc(4)+1 - ELSE - iflc1=next(ifreb) ! pointer to new free location - IF(jflc(1) == 0) THEN ! first item - jflc(1)=ifrea - ELSE - next(jflc(2))=ifrea - END IF - next(ifreb)=0 - jflc(2)=ifreb ! last index - jflc(3)=jflc(3)+1 ! counter - tk(1,ifrea)=four(1) - tk(2,ifrea)=four(2) - tk(1,ifreb)=four(3) - tk(2,ifreb)=four(4) - END IF - END IF - RETURN - - ENTRY stmacp(jflc,array,n) ! copy (cp) all pairs to array - n=0 - ind=jflc(1) -10 IF(ind == 0) RETURN - n=n+1 - array(1,n)=tk(1,ind) - array(2,n)=tk(2,ind) - ind=next(ind) - GO TO 10 - - ENTRY stmarm(jflc) ! remove (rm) stored paiirs - next(iflc2)=jflc(1) ! connect to free space - iflc2=jflc(2) ! new last free index - DO j=1,4 - jflc(j)=0 - END DO -END SUBROUTINE stmars ! init/ - -SUBROUTINE rmesig(x,n,xloc,xsca) ! robust mean and sigma - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - ! robust determination of location and scale parameter, - ! for Gaussian data: location=mean and scale=standard deviation - ! XLOC = median of X_i (N values in array X(N)) - ! XCSA = median of | X_i - XLOC |, times 1.4826 - - REAL(mps), INTENT(IN OUT) :: x(n) ! input array, modified - INTEGER(mpi), INTENT(IN) :: n - REAL(mps), INTENT(OUT) :: xloc - REAL(mps), INTENT(OUT) :: xsca - SAVE - ! ... - xloc=0.0 - xsca=0.0 - IF(n <= 0) RETURN - CALL heapf(x,n) ! sort - xloc=0.5*(x((n+1)/2)+x((n+2)/2)) ! location - DO i=1,n - x(i)=ABS(x(i)-xloc) - END DO - CALL heapf(x,n) ! sort - xsca=1.4826*0.5*(x((n+1)/2)+x((n+2)/2)) ! dispersion -END SUBROUTINE rmesig - - - diff --git a/millepede/mpmod.f90 b/millepede/mpmod.f90 deleted file mode 100644 index ff75267318..0000000000 --- a/millepede/mpmod.f90 +++ /dev/null @@ -1,306 +0,0 @@ -!> \file -!! Data structures. -!! -!! \author Claus Kleinwort, DESY, 2012 (Claus.Kleinwort@desy.de) -!! -!! \copyright -!! Copyright (c) 2012 - 2018 Deutsches Elektronen-Synchroton, -!! Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n -!! 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. \n\n -!! 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. \n\n -!! You should have received a copy of the GNU Library General Public -!! License along with this program (see the file COPYING.LIB for more -!! details); if not, write to the Free Software Foundation, Inc., -!! 675 Mass Ave, Cambridge, MA 02139, USA. -!! - -!> Parameters, variables, dynamic arrays. -!! -!! For parameters which can be set from command line or -!! steering files more details are available in: \ref option_page. - -MODULE mpmod - USE mpdef - IMPLICIT NONE - SAVE - ! steering parameters - INTEGER(mpi) :: ictest=0 !< test mode '-t' - INTEGER(mpi) :: metsol=0 !< solution method (1: inversion, 2: diagonalization, 3: \ref minresqlpmodule::minresqlp "MINRES-QLP") - INTEGER(mpi) :: matsto=2 !< (global) matrix storage mode (1: full, 2: sparse) - INTEGER(mpi) :: mprint=1 !< print flag (0: minimal, 1: normal, >1: more) - INTEGER(mpi) :: mdebug=0 !< debug flag (number of records to print) - INTEGER(mpi) :: mdebg2=10 !< number of measurements for record debug printout - INTEGER(mpi) :: mreqenf=25 !< required number of entries (for variable global parameter from binary Files) - INTEGER(mpi) :: mreqena=10 !< required number of entries (for variable global parameter from Accepted local fits) - INTEGER(mpi) :: mitera=1 !< number of iterations - INTEGER(mpi) :: nloopn=0 !< number of data reading, fitting loops - INTEGER(mpi) :: mbandw=0 !< band width of preconditioner matrix - INTEGER(mpi) :: lprecm=0 !< additional flag for preconditioner (band) matrix (>0: preserve rank by skyline matrix) - INTEGER(mpi) :: lunkno=0 !< flag for unkown keywords - INTEGER(mpi) :: lhuber=0 !< Huber down-weighting flag - REAL(mps) :: chicut=0.0 !< cut in terms of 3-sigma cut, first iteration - REAL(mps) :: chirem=0.0 !< cut in terms of 3-sigma cut, other iterations, approaching 1. - REAL(mps) :: chhuge=50.0 !< cut in terms of 3-sigma for unreasonable data, all iterations - INTEGER(mpi) :: nrecpr=0 !< record number with printout - INTEGER(mpi) :: nrecp2=0 !< record number with printout - INTEGER(mpi) :: nrec1 =0 !< record number with largest residual - INTEGER(mpi) :: nrec2 =0 !< record number with largest chi^2/Ndf - REAL(mps) :: value1=0.0!< largest residual - REAL(mps) :: value2=0.0!< largest chi^2/Ndf - REAL(mps) :: dwcut=0.0 !< down-weight fraction cut - INTEGER(mpi) :: isubit=0 !< subito flag '-s' - REAL(mps) :: wolfc1=0.0!< C_1 of strong Wolfe condition - REAL(mps) :: wolfc2=0.0!< C_2 of strong Wolfe condition - REAL(mpd) :: mrestl=1.0E-06 !< tolerance criterion for MINRES-QLP - REAL(mpd) :: mrtcnd=1.0E+07 !< transition (QR -> QLP) (matrix) condition for MINRES-QLP - INTEGER(mpi) :: mrmode=0 !< MINRES-QLP mode (0: QR+QLP, 1: only QR, 2: only QLP factorization) - INTEGER(mpi) :: nofeas=0 !< flag for skipping making parameters feasible - INTEGER(mpi) :: nhistp=0 !< flag for histogram printout - REAL(mps) :: delfun=0.0!< expected function change - REAL(mps) :: actfun=0.0!< actual function change - REAL(mps) :: angras=0.0!< angle between gradient and search direction - INTEGER(mpi) :: iterat=0 !< iterations in solution - INTEGER(mpi) :: nregul=0 !< regularization flag - REAL(mps) :: regula=1.0!< regularization parameter, add regula * norm(global par.) to objective function - REAL(mps) :: regpre=0.0!< default presigma - INTEGER(mpi) :: matrit=0 !< matrix calculation up to iteration MATRIT - INTEGER(mpi) :: icalcm=0 !< calculation mode (for \ref xloopn "XLOOPN") , >0: calculate matrix - INTEGER(mpi), DIMENSION(2) :: nbndr =0 !< number of records with bordered band matrix for local fit (upper/left, lower/right) - INTEGER(mpi) :: nbdrx =0 !< max border size for local fit - INTEGER(mpi) :: nbndx =0 !< max band width for local fit - INTEGER(mpi) :: nrecer=0 !< record with error (rank deficit or Not-a-Number) for printout - INTEGER(mpi) :: nrec3 = huge(nrec3) !< (1.) record number with error - INTEGER(mpi) :: mreqpe=1 !< min number of pair entries - INTEGER(mpi) :: mhispe=0 !< upper bound for pair entry histogrammimg - INTEGER(mpi) :: msngpe=-1 !< upper bound for pair entry single precision storage - INTEGER(mpi) :: mcmprs=0 !< compression flag for sparsity (column indices) - INTEGER(mpi) :: mextnd=0 !< flag for extended storage (both 'halves' of sym. mat. for improved access patterns) - INTEGER(mpi) :: mthrd =1 !< number of (OpenMP) threads - INTEGER(mpi) :: mxrec =0 !< max number of records - INTEGER(mpi) :: matmon=0 !< record interval for monitoring of (sparse) matrix construction - INTEGER(mpi) :: lfitnp=huge(lfitnp) !< local fit: number of iteration to calculate pulls - INTEGER(mpi) :: lfitbb=1 !< local fit: check for bordered band matrix (if >0) - INTEGER(mpi) :: mnrsel=0 !< number of MINRES error labels in LBMNRS (calc err, corr with SOLGLO) - INTEGER(mpi) :: ncache=-1 !< buffer size for caching (default 100MB per thread) - REAL(mps), DIMENSION(3) :: fcache = (/ 0.8, 0., 0. /) !< read cache, average fill level; write cache; dynamic size - INTEGER(mpi) :: mthrdr=1 !< number of threads for reading binary files - INTEGER(mpi) :: mnrsit=0 !< total number of MINRES internal iterations - INTEGER(mpi) :: iforce=0 !< switch to SUBITO for (global) rank defects if zero - INTEGER(mpi) :: igcorr=0 !< flag for output of global correlations for inversion, =0: none - INTEGER(mpi) :: memdbg=0 !< debug flag for memory management - REAL(mps) :: prange=0.0!< range (-PRANGE..PRANGE) for histograms of pulls, norm. residuals - INTEGER(mpi) :: lsearch=2 !< iterations (solutions) with line search: - !! >2: all, =2: all with (next) Chi2 cut scaling factor =1., =1: last, <1: none - INTEGER(mpi) :: ipcntr=0 !< flag for output of global parameter counts (entries), =0: none, =1: local fits, >1: binary files - INTEGER(mpi) :: iwcons=0 !< flag for weighting of constraints (>0: weighting with \ref globalparcounts "globalParCounts", else: none) - INTEGER(mpi) :: icelim=1 !< flag for using elimination (instead of multipliers) for constraints - INTEGER(mpi) :: icheck=0 !< flag for checking input only (no solution determined) - INTEGER(mpi) :: iteren=0 !< entries cut is iterated for parameters with less entries (if > \ref mreqenf) - INTEGER(mpi) :: iskpec=0 !< flag for skipping empty constraints (no variable parameters) - INTEGER(mpi) :: imonit=0 !< flag for monitoring residuals per local fit cycle (=0: none, <0: all, bit 0: first, bit 1: last) - INTEGER(mpi) :: measBins=100 !< number of bins per measurement for monitoring - INTEGER(mpi) :: imonmd=0 !< monitoring mode: 0:residuals (normalized to average error), 1:pulls - INTEGER(mpi) :: iscerr=0 !< flag for scaling of errors - REAL(mpd), DIMENSION(2) :: dscerr = (/ 1.0, 1.0 /) !< scaling factors for errors of 'global' and 'local' measurement - INTEGER(mpi) :: keepOpen=1 !< flag for keeping binary files open - - ! variables - INTEGER(mpi) :: lunmon !< unit for monitoring output file - INTEGER(mpi) :: lunlog !< unit for logfile - INTEGER(mpi) :: lvllog !< log level - INTEGER(mpi) :: ntgb !< total number of global parameters - INTEGER(mpi) :: nvgb !< number of variable global parameters - INTEGER(mpi) :: nagb !< number of all parameters (global par. + Lagrange mult.) - INTEGER(mpi) :: nfgb !< number of fit parameters - INTEGER(mpi) :: ncgb !< number of constraints - INTEGER(mpi) :: ncgbe !< number of empty constraints (no variable parameters) - INTEGER(mpi) :: ncblck !< number of (disjoint) constraint blocks - INTEGER(mpi) :: mszcon !< (integrated block) matrix size for constraint matrix - INTEGER(mpi) :: mszprd !< (integrated block) matrix size for (constraint) product matrix - INTEGER(mpi), DIMENSION(2) :: nprecond !< number of constraints, matrix size for preconditioner - INTEGER(mpi) :: nagbn !< max number of global paramters per record - INTEGER(mpi) :: nalcn !< max number of local paramters per record - INTEGER(mpi) :: naeqn !< max number of equations (measurements) per record - INTEGER(mpi) :: nrec !< number of records read - INTEGER(mpi) :: nrecd !< number of records read containing doubles - REAL(mps) :: dflim !< convergence limit - INTEGER(mpi), DIMENSION(0:3) :: nrejec !< rejected events - REAL(mps), DIMENSION(0:8) :: times !< cpu time counters - REAL(mps) :: stepl !< step length (line search) - CHARACTER (LEN=74) :: textl !< name of current MP 'module' (step) - LOGICAL :: newite !< flag for new iteration - INTEGER(mpi) :: ndfsum !< sum(ndf) - INTEGER(mpi) :: iitera !< MINRES iterations - INTEGER(mpi) :: istopa !< MINRES istop (convergence) - INTEGER(mpi) :: lsinfo !< line search: returned information - REAL :: rstart !< cpu start time for solution iterations - REAL(mps) :: deltim !< cpu time difference - INTEGER(mpi) :: npresg !< number of pre-sigmas - INTEGER(mpi) :: nrecal !< number of records - INTEGER(mpi) :: ndefec=0 !< rank deficit for global matrix (from inversion) - INTEGER(mpi) :: nmiss1=0 !< rank deficit for constraints - INTEGER(mpi) :: nalow=0 !< (sum of) global parameters with too few accepted entries - INTEGER(mpi) :: lcalcm !< last calclation mode - INTEGER(mpi) :: nspc=1 !< number of precision for sparse global matrix (1=D, 2=D+F) - INTEGER(mpi) :: nencdb !< encoding info (number bits for column counter) - INTEGER(mpi) :: numMeas !< number of measurement groups for monitoring - REAL(mpd), PARAMETER :: measBinSize=0.1 !< bins size for monitoring - INTEGER(mpi), DIMENSION(100) :: lbmnrs !< MINRES error labels - REAL(mpd) :: fvalue !< function value (chi2 sum) solution - REAL(mpd) :: flines !< function value line search - REAL(mpd) :: sumndf !< weighted sum(ndf) - ! each loop - INTEGER(mpi) :: numReadbuffer !< number of buffers (records) in (read) block - INTEGER(mpi) :: numBlocks !< number of (read) blocks - INTEGER(mpi) :: sumRecords !< sum of records - INTEGER(mpi) :: skippedRecords !< number of skipped records (buffer too small) - INTEGER(mpi) :: minRecordsInBlock !< min. records in block - INTEGER(mpi) :: maxRecordsInBlock !< max. records in block - ! accurate sumation - INTEGER(mpi), PARAMETER::nexp20=1048576 ! 2**20 - REAL(mpd)::accurateDsum=0.0_mpd !< fractional part of sum - INTEGER(mpi)::accurateNsum=0 !< sum mod 2**20 - INTEGER(mpi)::accurateNexp=0 !< sum / 2**20 - INTEGER(mpi) :: lenGlobalVec !< length of global vector 'b' (A*x=b) - ! dynamic arrays - !====================================================== - ! global parameters - REAL(mpd), DIMENSION(:), ALLOCATABLE :: globalParameter !< global parameters (start values + sum(x_i)) - REAL(mpd), DIMENSION(:), ALLOCATABLE :: globalParCopy !< copy of global parameters - REAL(mpd), DIMENSION(:), ALLOCATABLE :: globalCorrections !< correction x_i (from A*x_i=b_i in iteration i) - REAL(mpd), DIMENSION(:), ALLOCATABLE :: globalParStart !< start value for global parameters - REAL(mpd), DIMENSION(:), ALLOCATABLE :: globalParPreSigma !< pre-sigma for global parameters - REAL(mpd), DIMENSION(:), ALLOCATABLE :: globalParPreWeight !< weight from pre-sigma - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: globalParCounts !< global parameters counts (from binary files) - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: globalParCons !< global parameters (number of) constraints - ! global matrix, vector - REAL(mpd), DIMENSION(:), ALLOCATABLE :: globalMatD !< global matrix 'A' (double, full or sparse) - REAL(mps), DIMENSION(:), ALLOCATABLE :: globalMatF !< global matrix 'A' (float part for compressed sparse) - REAL(mpd), DIMENSION(:), ALLOCATABLE :: globalVector !< global vector 'x' (in A*x=b) - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: globalCounter !< global counter (entries in 'x') - ! AVPROD (A*x=b) by MINRES - REAL(mpd), DIMENSION(:), ALLOCATABLE :: vecXav !< vector x for AVPROD (A*x=b) - REAL(mpd), DIMENSION(:), ALLOCATABLE :: vecBav !< vector b for AVPROD (A*x=b) - ! preconditioning - REAL(mpd), DIMENSION(:), ALLOCATABLE :: matPreCond !< preconditioner (band) matrix - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: indPreCond !< preconditioner pointer array - ! auxiliary vectors - REAL(mpd), DIMENSION(:), ALLOCATABLE :: workspaceD !< (general) workspace (D) - REAL(mpd), DIMENSION(:), ALLOCATABLE :: workspaceDiag !< diagonal of global matrix (for global corr.) - REAL(mpd), DIMENSION(:), ALLOCATABLE :: workspaceLinesearch !< workspace line search - REAL(mpd), DIMENSION(:), ALLOCATABLE :: workspaceDiagonalization !< workspace diag. - REAL(mpd), DIMENSION(:), ALLOCATABLE :: workspaceEigenValues !< workspace eigen values - REAL(mpd), DIMENSION(:), ALLOCATABLE :: workspaceEigenVectors !< workspace eigen vectors - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: workspaceI !< (general) workspace (I) - ! constraint matrix, residuals - REAL(mpd), DIMENSION(:), ALLOCATABLE :: matConsProduct !< product matrix of constraints - REAL(mpd), DIMENSION(:), ALLOCATABLE :: vecConsResiduals !< residuals of constraints - REAL(mpd), DIMENSION(:), ALLOCATABLE :: vecConsSolution !< solution for constraint elimination - ! constraint sorting, blocks - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecConsStart !< start of constraint in listConstraints (unsorted input) - INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: matConsSort !< keys and index for sorting - INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: matConsBlocks !< start of constraint blocks, parameter range - ! monitoring of input residuals - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: measIndex !< mapping of 1. global label to measurement index - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: measHists !< measurement histograms (100 bins per thread) - REAL(mpd), DIMENSION(:), ALLOCATABLE :: measRes !< average measurement error - ! global parameter mapping - INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: globalParLabelIndex !< global parameters label, total -> var. index - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: globalParHashTable !< global parameters hash table - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: globalParVarToTotal !< global parameters variable -> total index - INTEGER(mpi), DIMENSION(-7:0) :: globalParHeader = 0 !< global parameters (mapping) header - !! - !! 0: length of labels/indices; \n - !! -1: number of stored items; \n - !! -2: =0 during build-up; \n - !! -3: next number; \n - !! -4: (largest) prime number (< length); \n - !! -5: number of overflows; \n - !! -6: nr of variable parameters; \n - !! -7: call counter for build-up; - - ! row information for sparse matrix - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: sparseMatrixCompression !< compression info (per row) - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: sparseMatrixColumns !< (compressed) list of columns for sparse matrix - INTEGER(mpl), DIMENSION(:,:), ALLOCATABLE :: sparseMatrixOffsets !< row offsets for column list, sparse matrix elements - ! read buffer - INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: readBufferInfo !< buffer management (per thread) - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: readBufferPointer !< pointer to used buffers - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: readBufferDataI !< integer data - REAL(mpr4), DIMENSION(:), ALLOCATABLE :: readBufferDataF !< float data - REAL(mpr8), DIMENSION(:), ALLOCATABLE :: readBufferDataD !< double data - ! global parameter usage in record - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: globalIndexUsage !< indices of global par in record - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: backIndexUsage !< list of global par in record - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: appearanceCounter !< appearance statistics for global par (first/last file,record) - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: pairCounter !< number of paired parameters (in equations) - ! local fit - REAL(mpd), DIMENSION(:), ALLOCATABLE::blvec !< local fit vector 'b' (in A*x=b), replaced by 'x' - REAL(mpd), DIMENSION(:), ALLOCATABLE::clmat !< local fit matrix 'A' (in A*x=b) - INTEGER(mpi), DIMENSION(:), ALLOCATABLE:: ibandh !< local fit 'band width histogram' (band size autodetection) - ! scratch arrays for local fit - REAL(mpd), DIMENSION(:), ALLOCATABLE::vbnd !< local fit band part of 'A' - REAL(mpd), DIMENSION(:), ALLOCATABLE::vbdr !< local fit border part of 'A' - REAL(mpd), DIMENSION(:), ALLOCATABLE::aux !< local fit 'solutions for border rows' - REAL(mpd), DIMENSION(:), ALLOCATABLE::vbk !< local fit 'matrix for border solution' - REAL(mpd), DIMENSION(:), ALLOCATABLE::vzru !< local fit 'border solution' - REAL(mpd), DIMENSION(:), ALLOCATABLE::scdiag !< local fit workspace (D) - INTEGER(mpi), DIMENSION(:), ALLOCATABLE:: scflag !< local fit workspace (I) - REAL(mpd), DIMENSION(:), ALLOCATABLE :: localCorrections !< local fit corrections (to residuals) - REAL(mpd), DIMENSION(:), ALLOCATABLE :: localGlobalMatrix !< matrix correlating local and global par - ! update of global matrix - INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: writeBufferInfo !< write buffer management (per thread) - REAL(mps), DIMENSION(:,:), ALLOCATABLE :: writeBufferData !< write buffer data (largest residual, Chi2/ndf, per thread) - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: writeBufferIndices !< write buffer for indices - REAL(mpd), DIMENSION(:), ALLOCATABLE :: writeBufferUpdates !< write buffer for update matrices - INTEGER(mpi), DIMENSION(-6:6) :: writeBufferHeader = 0 !< write buffer header (-6..-1: updates, 1..6: indices) - !! - !! +/-1: buffer size (words) per thread; \n - !! +/-2: min number of free words; \n - !! +/-3: number of buffer flushes; \n - !! +/-4: number of buffer overruns; \n - !! +/-5: average fill level; \n - !! +/-6: peak fill level; - !> list items from steering file - INTEGER(mpi) :: lenParameters=0 !< length of list of parameters from steering file - TYPE(listItem), DIMENSION(:), ALLOCATABLE :: listParameters !< list of parameters from steering file - INTEGER(mpi) :: lenPresigmas=0 !< length of list of pre-sigmas from steering file - TYPE(listItem), DIMENSION(:), ALLOCATABLE :: listPreSigmas !< list of pre-sgmas from steering file - INTEGER(mpi) :: lenConstraints=0 !< length of list of constraints from steering file - TYPE(listItem), DIMENSION(:), ALLOCATABLE :: listConstraints !< list of constraints from steering file - INTEGER(mpi) :: numMeasurements=0 !< number of (external) measurements from steering file - INTEGER(mpi) :: lenMeasurements=0 !< length of list of (external) measurements from steering file - TYPE(listItem), DIMENSION(:), ALLOCATABLE :: listMeasurements !< list of (external) measurements from steering file - !====================================================== - ! file information - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: mfd !< file mode: cbinary =1, text =2, fbinary=3 - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: lfd !< length of file name - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: nfd !< index (line) in (steering) file - INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: kfd !< (1,.)= number of records in file, (2,..)= file order - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: ifd !< file: integrated record numbers (=offset) - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: jfd !< file: number of accepted records - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: dfd !< file: ndf sum - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: xfd !< file: max. record size - REAL(mps), DIMENSION(:), ALLOCATABLE :: cfd !< file: chi2 sum - REAL(mps), DIMENSION(:), ALLOCATABLE :: ofd !< file: option - REAL(mps), DIMENSION(:), ALLOCATABLE :: wfd !< binary file: weight - INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: sfd !< offset (1,..), length (2,..) of binary file name in tfd - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: yfd !< binary file: modification date - CHARACTER (LEN=1024) :: filnam !< name of steering file - INTEGER(mpi) :: nfnam !< length of sterring file name - CHARACTER, DIMENSION(:), ALLOCATABLE :: tfd !< file names (concatenation) - INTEGER(mpi) :: ifile !< current file (index) - INTEGER(mpi) :: nfiles !< number of files - INTEGER(mpi) :: nfilb !< number of binary files - INTEGER(mpi) :: nfilf !< number of Fortran binary files - INTEGER(mpi) :: nfilc !< number of C binary files - INTEGER(mpi) :: nfilw !< number of weighted binary files - INTEGER(mpi) :: ndimbuf=10000 !< default read buffer size (I/F words, half record length) - -END MODULE mpmod diff --git a/millepede/mpnum.f90 b/millepede/mpnum.f90 deleted file mode 100644 index 00bc461df2..0000000000 --- a/millepede/mpnum.f90 +++ /dev/null @@ -1,2835 +0,0 @@ - -! Code converted using TO_F90 by Alan Miller -! Date: 2012-03-16 Time: 11:07:48 - -!> \file -!! General linear algebra routines. -!! -!! \author Volker Blobel, University Hamburg, 2005-2009 (initial Fortran77 version) -!! \author Claus Kleinwort, DESY (maintenance and developement) -!! -!! \copyright -!! Copyright (c) 2009 - 2015 Deutsches Elektronen-Synchroton, -!! Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n -!! 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. \n\n -!! 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. \n\n -!! You should have received a copy of the GNU Library General Public -!! License along with this program (see the file COPYING.LIB for more -!! details); if not, write to the Free Software Foundation, Inc., -!! 675 Mass Ave, Cambridge, MA 02139, USA. -!! -!! ***** Collection of utility routines from V. Blobel ***** -!! -!! V. Blobel, Univ. Hamburg -!! Numerical subprograms used in MP-II: matrix equations, -!! and matrix products, double precision -!! -!! Solution by inversion -!! SQMINV -!! SQMINL for LARGE matrix, use OpenMP (CHK) -!! -!! Solution by diagonalization -!! DEVROT, DEVPRT, DEFSOL,DEVINV -!! -!! Solution by Cholesky decomposition of symmetric matrix -!! CHOLDC -!! -!! Solution by Cholesky decomposition of variable-band matrix -!! VABDEC -!! -!! Solution by Cholesky decomposition of bordered band matrix -!! SQMIBB upper/left border (CHK) -!! SQMIBB2 lower/right border (CHK) -!! -!! Matrix/vector products -!! DBDOT dot vector product -!! DBAXPY multiplication and addition -!! DBSVX symmetric matrix vector -!! DBSVX LARGE symmetric matrix vector (CHK) -!! DBGAX general matrix vector -!! DBAVAT AVAT product -!! DBMPRV print parameter and matrix -!! DBPRV print matrix (CHK) -!! -!! Chi^2 cut values -!! CHINDL -!! -!! Accurate summation (moved to pede.f90) -!! ADDSUM -!! -!! Sorting -!! HEAPF heap sort reals direct -!! SORT1K sort 1-dim key-array (CHK) -!! SORT2K sort 2-dim key-array -!! SORT2I sort 2-dim key-array with index (CHK) -!! - -!---------------------------------------------------------------------- -!> Matrix inversion and solution. -!! -!! Obtain solution of a system of linear equations with symmetric -!! matrix (V * X = B) and the inverse. -!! -!! Method of solution is by elimination selecting the pivot on the -!! diagonal each stage. The rank of the matrix is returned in NRANK. -!! For NRANK ne N, all remaining rows and cols of the resulting -!! matrix V and the corresponding elements of B are set to zero. -!! -!! \param [in,out] V symmetric N-by-N matrix in symmetric storage mode -!! (V(1) = V11, V(2) = V12, V(3) = V22, V(4) = V13, ...), -!! replaced by inverse matrix -!! \param [in,out] B N-vector, replaced by solution vector -!! \param [in] N size of V, B -!! \param [out] NRANK rank of matrix V -!! \param [out] DIAG double precision scratch array -!! \param [out] NEXT INTEGER(mpi) aux array - -SUBROUTINE sqminv(v,b,n,nrank,diag,next) ! matrix inversion - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ij - INTEGER(mpi) :: j - INTEGER(mpi) :: jj - INTEGER(mpi) :: jk - INTEGER(mpi) :: jl - INTEGER(mpi) :: k - INTEGER(mpi) :: kk - INTEGER(mpi) :: l - INTEGER(mpi) :: last - INTEGER(mpi) :: lk - INTEGER(mpi) :: next0 - - REAL(mpd), INTENT(IN OUT) :: v(*) - REAL(mpd), INTENT(OUT) :: b(n) - INTEGER(mpi), INTENT(IN) :: n - INTEGER(mpi), INTENT(OUT) :: nrank - REAL(mpd), INTENT(OUT) :: diag(n) - INTEGER(mpi), INTENT(OUT) :: next(n) - REAL(mpd) :: vkk - REAL(mpd) :: vjk - - !REAL(mpd), PARAMETER :: eps=1.0E-10_mpd - REAL(mpd) eps - ! ... - eps = 16.0_mpd * epsilon(eps) ! 16 * precision(mpd) - - next0=1 - l=1 - DO i=1,n - next(i)=i+1 ! set "next" pointer - diag(i)=ABS(v((i*i+i)/2)) ! save abs of diagonal elements - END DO - next(n)=-1 ! end flag - - nrank=0 - DO i=1,n ! start of loop - k =0 - vkk=0.0_mpd - - j=next0 - last=0 -05 IF(j > 0) THEN - jj=(j*j+j)/2 - IF(ABS(v(jj)) > MAX(ABS(vkk),eps*diag(j))) THEN - vkk=v(jj) - k=j - l=last - END IF - last=j - j=next(last) - GO TO 05 - END IF - - IF(k /= 0) THEN ! pivot found - kk=(k*k+k)/2 - IF(l == 0) THEN - next0=next(k) - ELSE - next(l)=next(k) - END IF - next(k)=0 ! index is used, reset - nrank=nrank+1 ! increase rank and ... - vkk =1.0/vkk - v(kk) =-vkk - b(k) =b(k)*vkk - jk =kk-k - jl =0 - DO j=1,n ! elimination - IF(j == k) THEN - jk=kk - jl=jl+j - ELSE - IF(j < k) THEN - jk=jk+1 - ELSE - jk=jk+j-1 - END IF - vjk =v(jk) - v(jk)=vkk*vjk - b(j) =b(j)-b(k)*vjk - lk =kk-k - DO l=1,j - jl=jl+1 - IF(l == k) THEN - lk=kk - ELSE - IF(l < k) THEN - lk=lk+1 - ELSE - lk=lk+l-1 - END IF - v(jl)=v(jl)-v(lk)*vjk - END IF - END DO - END IF - END DO - ELSE - DO k=1,n - IF(next(k) /= 0) THEN - b(k)=0.0_mpd ! clear vector element - DO j=1,k - IF(next(j) /= 0) v((k*k-k)/2+j)=0.0_mpd ! clear matrix row/col - END DO - END IF - END DO - GO TO 10 - END IF - END DO ! end of loop - 10 DO ij=1,(n*n+n)/2 - v(ij)=-v(ij) ! finally reverse sign of all matrix elements - END DO -END SUBROUTINE sqminv - -!> Matrix inversion for LARGE matrices. -!! -!! Like SQMINV, additional parallelization with OpenMP. -!! -!! \param [in,out] V symmetric N-by-N matrix in symmetric storage mode -!! (V(1) = V11, V(2) = V12, V(3) = V22, V(4) = V13, ...), -!! replaced by inverse matrix -!! \param [in,out] B N-vector, replaced by solution vector -!! \param [in] N size of V, B -!! \param [out] NRANK rank of matrix V -!! \param [out] DIAG double precision scratch array -!! \param [out] NEXT integer aux array - -SUBROUTINE sqminl(v,b,n,nrank,diag,next) ! - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: k - INTEGER(mpi) :: l - INTEGER(mpi) :: last - INTEGER(mpi) :: next0 - - REAL(mpd), INTENT(IN OUT) :: v(*) - REAL(mpd), INTENT(OUT) :: b(n) - INTEGER(mpi), INTENT(IN) :: n - INTEGER(mpi), INTENT(OUT) :: nrank - REAL(mpd), INTENT(OUT) :: diag(n) - INTEGER(mpi), INTENT(OUT) :: next(n) - INTEGER(mpl) :: i8 - INTEGER(mpl) :: j8 - INTEGER(mpl) :: jj - INTEGER(mpl) :: k8 - INTEGER(mpl) :: kk - INTEGER(mpl) :: kkmk - INTEGER(mpl) :: jk - INTEGER(mpl) :: jl - INTEGER(mpl) :: llk - INTEGER(mpl) :: ljl - - REAL(mpd) :: vkk - REAL(mpd) :: vjk - - REAL(mpd), PARAMETER :: eps=1.0E-10_mpd - ! ... - next0=1 - l=1 - DO i=1,n - i8=int8(i) - next(i)=i+1 ! set "next" pointer - diag(i)=ABS(v((i8*i8+i8)/2)) ! save abs of diagonal elements - END DO - next(n)=-1 ! end flag - - nrank=0 - DO i=1,n ! start of loop - k =0 - vkk=0.0_mpd - j=next0 - last=0 -05 IF(j > 0) THEN - j8=int8(j) - jj=(j8*j8+j8)/2 - IF(ABS(v(jj)) > MAX(ABS(vkk),eps*diag(j))) THEN - vkk=v(jj) - k=j - l=last - END IF - last=j - j=next(last) - GO TO 05 - END IF - - IF(k /= 0) THEN ! pivot found - k8=int8(k) - kk=(k8*k8+k8)/2 - kkmk=kk-k8 - IF(l == 0) THEN - next0=next(k) - ELSE - next(l)=next(k) - END IF - next(k)=0 ! index is used, reset - nrank=nrank+1 ! increase rank and ... - vkk =1.0/vkk - v(kk) =-vkk - b(k) =b(k)*vkk - ! elimination - jk =kkmk - DO j=1,n - IF(j == k) THEN - jk=kk - ELSE - IF(j < k) THEN - jk=jk+1 - ELSE - jk=jk+int8(j)-1 - END IF - v(jk)=v(jk)*vkk - END IF - END DO - ! parallelize row loop - ! slot of 128 'J' for next idle thread - !$OMP PARALLEL DO & - !$OMP PRIVATE(JL,JK,L,LJL,LLK,VJK,J8) & - !$OMP SCHEDULE(DYNAMIC,128) - DO j=n,1,-1 - j8=int8(j) - jl=j8*(j8-1)/2 - IF(j /= k) THEN - IF(j < k) THEN - jk=kkmk+j8 - ELSE - jk=k8+jl - END IF - vjk =v(jk)/vkk - b(j) =b(j)-b(k)*vjk - ljl=jl - llk=kkmk - DO l=1,MIN(j,k-1) - ljl=ljl+1 - llk=llk+1 - v(ljl)=v(ljl)-v(llk)*vjk - END DO - ljl=ljl+1 - llk=kk - DO l=k+1,j - ljl=ljl+1 - llk=llk+l-1 - v(ljl)=v(ljl)-v(llk)*vjk - END DO - END IF - END DO - !$OMP END PARALLEL DO - ELSE - DO k=1,n - k8=int8(k) - kk=(k8*k8-k8)/2 - IF(next(k) /= 0) THEN - b(k)=0.0_mpd ! clear vector element - DO j=1,k - IF(next(j) /= 0) v(kk+int8(j))=0.0_mpd ! clear matrix row/col - END DO - END IF - END DO - GO TO 10 - END IF - END DO ! end of loop - 10 DO jj=1,(int8(n)*int8(n)+int8(n))/2 - v(jj)=-v(jj) ! finally reverse sign of all matrix elements - END DO -END SUBROUTINE sqminl - -!> Diagonalization. -!! -!! Determination of eigenvalues and eigenvectors of -!! symmetric matrix V by Householder method -!! -!! \param [in] n size of matrix -!! \param [out] diag diagonal elements -!! \param [out] u transformation matrix -!! \param [in] v symmetric matrix, unchanged -!! \param [out] work work array -!! \param [out] iwork work array - -SUBROUTINE devrot(n,diag,u,v,work,iwork) ! diagonalization - USE mpdef - - IMPLICIT NONE - - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(OUT) :: diag(n) - REAL(mpd), INTENT(OUT) :: u(n,n) - REAL(mpd), INTENT(IN) :: v(*) - REAL(mpd), INTENT(OUT) :: work(n) - INTEGER(mpi), INTENT(OUT) :: iwork(n) - - - INTEGER(mpi), PARAMETER :: itmax=30 - REAL(mpd), PARAMETER :: tol=EPSILON(tol) - REAL(mpd), PARAMETER :: eps=EPSILON(eps) - - REAL(mpd) :: f - REAL(mpd) :: g - REAL(mpd) :: h - REAL(mpd) :: sh - REAL(mpd) :: hh - REAL(mpd) :: b - REAL(mpd) :: p - REAL(mpd) :: r - REAL(mpd) :: s - REAL(mpd) :: c - REAL(mpd) :: workd - - INTEGER(mpi) :: ij - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: k - INTEGER(mpi) :: l - INTEGER(mpi) :: m - INTEGER(mpi) :: ll - ! ... - ! 1. part: symmetric matrix V reduced to tridiagonal from - ij=0 - DO i=1,n - DO j=1,i - ij=ij+1 - u(i,j)=v(ij) ! copy half of symmetric matirx - END DO - END DO - - DO i=n,2,-1 - l=i-2 - f=u(i,i-1) - g=0.0_mpd - IF(l /= 0) THEN - DO k=1,l - IF(ABS(u(i,k)) > tol) g=g+u(i,k)*u(i,k) - END DO - h=g+f*f - END IF - IF(g < tol) THEN ! G too small - work(i)=f ! skip transformation - h =0.0_mpd - ELSE - l=l+1 - sh=SQRT(h) - IF(f >= 0.0_mpd) sh=-sh - g=sh - work(i)=sh - h=h-f*g - u(i,i-1)=f-g - f=0.0_mpd - DO j=1,l - u(j,i)=u(i,j)/h - g=0.0_mpd - ! form element of a u - DO k=1,j - IF(ABS(u(j,k)) > tol.AND.ABS(u(i,k)) > tol) THEN - g=g+u(j,k)*u(i,k) - END IF - END DO - DO k=j+1,l - IF(ABS(u(k,j)) > tol.AND.ABS(u(i,k)) > tol) THEN - g=g+u(k,j)*u(i,k) - END IF - END DO - work(j)=g/h - f=f+g*u(j,i) - END DO - ! form k - hh=f/(h+h) - ! form reduced a - DO j=1,l - f=u(i,j) - work(j)=work(j)-hh*f - g=work(j) - DO k=1,j - u(j,k)=u(j,k)-f*work(k)-g*u(i,k) - END DO - END DO - END IF - diag(i)=h - END DO - - diag(1)=0.0_mpd - work(1)=0.0_mpd - - ! accumulation of transformation matrices - DO i=1,n - IF(diag(i) /= 0.0) THEN - DO j=1,i-1 - g=0.0_mpd - DO k=1,i-1 - g=g+u(i,k)*u(k,j) - END DO - DO k=1,i-1 - u(k,j)=u(k,j)-g*u(k,i) - END DO - END DO - END IF - diag(i)=u(i,i) - u(i,i)=1.0_mpd - DO j=1,i-1 - u(i,j)=0.0_mpd - u(j,i)=0.0_mpd - END DO - END DO - - ! 2. part: diagonalization of tridiagonal matrix - DO i=2,n - work(i-1)=work(i) - END DO - work(n)=0.0_mpd - b=0.0_mpd - f=0.0_mpd - - DO l=1,n - j=0 - h=eps*(ABS(diag(l))+ABS(work(l))) - IF(b < h) b=h - DO m=l,n - IF(ABS(work(m)) <= b) GO TO 10 ! look for small sub-diagonal element - END DO - m=l -10 IF(m == l) GO TO 30 - ! next iteration -20 IF(j == itmax) THEN - WRITE(*,*) 'DEVROT: Iteration limit reached' - CALL peend(32,'Aborted, iteration limit reached in diagonalization') - STOP - END IF - j=j+1 - g=diag(l) - p=(diag(l+1)-g)/(2.0_mpd*work(l)) - r=SQRT(1.0_mpd+p*p) - diag(l)=work(l) - IF(p < 0.0_mpd) diag(l)=diag(l)/(p-r) - IF(p >= 0.0_mpd) diag(l)=diag(l)/(p+r) - h=g-diag(l) - DO i=l+1,n - diag(i)=diag(i)-h - END DO - f=f+h - ! QL transformation - p=diag(m) - c=1.0_mpd - s=0.0_mpd - DO i=m-1,l,-1 ! reverse loop - g=c*work(i) - h=c*p - IF(ABS(p) >= ABS(work(i))) THEN - c=work(i)/p - r=SQRT(1.0_mpd+c*c) - work(i+1)=s*p*r - s=c/r - c=1.0_mpd/r - ELSE - c=p/work(i) - r=SQRT(1.0_mpd+c*c) - work(i+1)=s*work(i)*r - s=1.0_mpd/r - c=c/r - END IF - p=c*diag(i)-s*g - diag(i+1)=h+s*(c*g+s*diag(i)) - ! form vector - DO k=1,n - h=u(k,i+1) - u(k,i+1)=s*u(k,i)+c*h - u(k,i)=c*u(k,i)-s*h - END DO - END DO - work(l)=s*p - diag(l)=c*p - IF(ABS(work(l)) > b) GO TO 20 ! next iteration -30 diag(l)=diag(l)+f - END DO - DO i=1,n - iwork(i)=i - END DO - - m=1 -40 m=1+3*m ! determine initial increment - IF(m <= n) GO TO 40 -50 m=m/3 - DO j=1,n-m ! sort with increment M - l=j -60 IF(diag(iwork(l+m)) > diag(iwork(l))) THEN ! compare - ll=iwork(l+m) ! exchange the two index values - iwork(l+m)=iwork(l) - iwork(l)=ll - l=l-m - IF(l > 0) GO TO 60 - END IF - END DO - IF(m > 1) GO TO 50 - - DO i=1,n - IF(iwork(i) /= i) THEN - ! move vector from position I to the work area - workd=diag(i) - DO l=1,n - work(l)=u(l,i) - END DO - k=i -70 j=k - k=iwork(j) - iwork(j)=j - IF(k /= i) THEN - ! move vector from position K to the (free) position J - diag(j)=diag(k) - DO l=1,n - u(l,j)=u(l,k) - END DO - GO TO 70 - END IF - ! move vector from the work area to position J - diag(j)=workd - DO l=1,n - u(l,j)=work(l) - END DO - END IF - END DO -END SUBROUTINE devrot - -!> Calculate significances. -SUBROUTINE devsig(n,diag,u,b,coef) - USE mpdef - - IMPLICIT NONE - - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN) :: diag(n) - REAL(mpd), INTENT(IN) :: u(n,n) - REAL(mpd), INTENT(IN) :: b(n) - REAL(mpd), INTENT(OUT) :: coef(n) - INTEGER(mpi) :: i - INTEGER(mpi) :: j - REAL(mpd) :: dsum - ! ... - DO i=1,n - coef(i)=0.0_mpd - IF(diag(i) > 0.0_mpd) THEN - dsum=0.0_mpd - DO j=1,n - dsum=dsum+u(j,i)*b(j) - END DO - coef(i)=ABS(dsum)/SQRT(diag(i)) - END IF - END DO -END SUBROUTINE devsig - - -!> Solution by diagonalization. -!! -!! Solution of matrix equation V * X = B after diagonalization of V. -!! -!! \param [in] N size of matrix -!! \param [in] DIAG diagonal elements -!! \param [in] U transformation matrix -!! \param [in] B r.h.s. of matrix equation (unchanged) -!! \param [out] X solution vector -!! \param [out] WORK work array - -SUBROUTINE devsol(n,diag,u,b,x,work) - USE mpdef - - IMPLICIT NONE - - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN) :: diag(n) - REAL(mpd), INTENT(IN) :: u(n,n) - REAL(mpd), INTENT(IN) :: b(n) - REAL(mpd), INTENT(OUT) :: x(n) - REAL(mpd), INTENT(OUT) :: work(n) - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: jj - REAL(mpd) :: s - ! ... - DO j=1,n - s=0.0_mpd - work(j)=0.0_mpd - IF(diag(j) /= 0.0_mpd) THEN - DO i=1,n - ! j-th eigenvector is U(.,J) - s=s+u(i,j)*b(i) - END DO - work(j)=s/diag(j) - END IF - END DO - - DO j=1,n - s=0.0_mpd - DO jj=1,n - s=s+u(j,jj)*work(jj) - END DO - x(j)=s - END DO -! WRITE(*,*) 'DEVSOL' -! WRITE(*,*) 'X ',X -END SUBROUTINE devsol - -!> Inversion by diagonalization. -!! Get inverse matrix V from DIAG and U. -!! -!! \param [in] N size of matrix -!! \param [in] DIAG diagonal elements -!! \param [in] U transformation matrix -!! \param [out] V smmmetric matrix - -SUBROUTINE devinv(n,diag,u,v) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ij - INTEGER(mpi) :: j - INTEGER(mpi) :: k - - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN) :: diag(n) - REAL(mpd), INTENT(IN) :: u(n,n) - REAL(mpd), INTENT(OUT) :: v(*) - REAL(mpd) :: dsum - ! ... - ij=0 - DO i=1,n - DO j=1,i - ij=ij+1 - dsum=0.0_mpd - DO k=1,n - IF(diag(k) /= 0.0_mpd) THEN - dsum=dsum+u(i,k)*u(j,k)/diag(k) - END IF - END DO - v(ij)=dsum - END DO - END DO -END SUBROUTINE devinv - - -!> Cholesky decomposition. -!! -!! Cholesky decomposition of the matrix G: G = L D L^T -!! -!! - G = symmetric matrix, in symmetric storage mode -!! -!! - L = unit triangular matrix (1's on diagonal) -!! -!! - D = diagonal matrix (elements store on diagonal of L) -!! -!! The sqrts of the usual Cholesky decomposition are avoided by D. -!! Matrices L and D are stored in the place of matrix G; after the -!! decomposition, the solution of matrix equations and the computation -!! of the inverse of the (original) matrix G are done by CHOLSL and CHOLIN. -!! -!! \param [in,out] g symmetric matrix, replaced by D,L -!! \param [in] n size of matrix -!! -SUBROUTINE choldc(g,n) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ii - INTEGER(mpi) :: j - INTEGER(mpi) :: jj - INTEGER(mpi) :: k - INTEGER(mpi) :: kk - - REAL(mpd), INTENT(IN OUT) :: g(*) - INTEGER(mpi), INTENT(IN) :: n - - REAL(mpd) :: ratio - ! ... - ii=0 - DO i=1,n - ii=ii+i - IF(g(ii) /= 0.0) g(ii)=1.0/g(ii) ! (I,I) div ! - jj=ii - DO j=i+1,n - ratio=g(i+jj)*g(ii) ! (I,J) (I,I) - kk=jj - DO k=j,n - g(kk+j)=g(kk+j)-g(kk+i)*ratio ! (K,J) (K,I) - kk=kk+k - END DO ! K - g(i+jj)=ratio ! (I,J) - jj=jj+j - END DO ! J - END DO ! I - RETURN -END SUBROUTINE choldc - -!> Solution after decomposition. -!! -!! The matrix equation G X = B is solved for X, where the matrix -!! G in the argument is already decomposed by CHOLDC. The vector B -!! is called X in the argument and the content is replaced by the -!! resulting vector X. -!! -!! \param [in] g decomposed symmetric matrix -!! \param [in,out] x r.h.s vector B, replaced by solution vector X -!! \param [in] n size of matrix -!! -SUBROUTINE cholsl(g,x,n) - USE mpdef - - IMPLICIT NONE - REAL(mpd) :: dsum - INTEGER(mpi) :: i - INTEGER(mpi) :: ii - INTEGER(mpi) :: k - INTEGER(mpi) :: kk - - REAL(mpd), INTENT(IN) :: g(*) - REAL(mpd), INTENT(IN OUT) :: x(n) - INTEGER(mpi), INTENT(IN) :: n - - ii=0 - DO i=1,n - dsum=x(i) - DO k=1,i-1 - dsum=dsum-g(k+ii)*x(k) ! (K,I) - END DO - x(i)=dsum - ii=ii+i - END DO - DO i=n,1,-1 - dsum=x(i)*g(ii) ! (I,I) - kk=ii - DO k=i+1,n - dsum=dsum-g(kk+i)*x(k) ! (K,I) - kk=kk+k - END DO - x(i)=dsum - ii=ii-i - END DO - RETURN -END SUBROUTINE cholsl - -!> Inversion after decomposition. -!! -!! The inverse of the (original) matrix G is computed and stored -!! in symmetric storage mode in matrix V. Arrays G and V must be -!! different arrays. -!! -!! \param [in] g decomposed symmetric matrix -!! \param [in,out] v inverse matrix -!! \param [in] n size of matrix -!! -SUBROUTINE cholin(g,v,n) - USE mpdef - - IMPLICIT NONE - REAL(mpd) :: dsum - INTEGER(mpi) :: i - INTEGER(mpi) :: ii - INTEGER(mpi) :: j - INTEGER(mpi) :: k - INTEGER(mpi) :: l - INTEGER(mpi) :: m - - REAL(mpd), INTENT(IN) :: g(*) - REAL(mpd), INTENT( OUT) :: v(*) - INTEGER(mpi), INTENT(IN) :: n - - ii=(n*n-n)/2 - DO i=n,1,-1 - dsum=g(ii+i) ! (I,I) - DO j=i,1,-1 - DO k=j+1,n - l=MIN(i,k) - m=MAX(i,k) - dsum=dsum-g(j+(k*k-k)/2)*v(l+(m*m-m)/2) ! (J,K) (I,K) - END DO - v(ii+j)=dsum ! (I,J) - dsum=0.0_mpd - END DO - ii=ii-i+1 - END DO -END SUBROUTINE cholin - -! variable band matrix operations ---------------------------------- - -!> Variable band matrix decomposition. -!! -!! Decomposition: A = L D L^T -!! -!! Variable-band matrix row Doolittle decomposition. -!! A variable-band NxN symmetric matrix, also called skyline, is stored -!! row by row in the array VAL(.). For each row every coefficient -!! between the first non-zero element in the row and the diagonal is -!! stored. -!! The pointer array ILPTR(N) contains the indices in VAL(.) of the -!! diagonal elements. ILPTR(1) is always 1, and ILPTR(N) is equal -!! to the total number of coefficients stored, called the profile. -!! The form of a variable-band matrix is preserved in the L D L^T -!! decomposition no fill-in is created ahead in any row or ahead of the -!! first entry in any column, but existing zero-values will become -!! non-zero. The decomposition is done "in-place". -!! -!! \param [in] n size of matrix -!! \param [in,out] val variable-band matrix, replaced by D,L -!! \param [in] ilptr pointer array - -SUBROUTINE vabdec(n,val,ilptr) - USE mpdef - - IMPLICIT NONE - - INTEGER(mpi) :: i - INTEGER(mpi) :: in - INTEGER(mpi) :: j - INTEGER(mpi) :: k - INTEGER(mpi) :: kj - INTEGER(mpi) :: mj - INTEGER(mpi) :: mk - REAL(mpd) :: sn - REAL(mpd) :: beta - REAL(mpd) :: delta - REAL(mpd) :: theta - - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN OUT) :: val(*) - INTEGER(mpi), INTENT(IN) :: ilptr(n) - - REAL(mpd) :: dgamma - REAL(mpd) :: xi - REAL(mpd) :: valkj - - REAL(mpd), PARAMETER :: one=1.0_mpd - REAL(mpd), PARAMETER :: two=2.0_mpd - REAL(mpd), PARAMETER :: eps = EPSILON(eps) - - WRITE(*,*) 'Variable band matrix Cholesky decomposition' - - dgamma=0.0_mpd - i=1 - DO j=1,ilptr(n) ! loop thrugh all matrix elements - IF(ilptr(i) == j) THEN ! diagonal element - IF(val(j) <= 0.0_mpd) GO TO 01 ! exit loop for negative diag - dgamma=MAX(dgamma,ABS(val(j))) ! max diagonal element - i=i+1 - END IF - END DO - i=n+1 -01 in=i-1 ! IN positive diagonal elements - WRITE(*,*) ' ',in,' positive diagonal elements' - xi=0.0_mpd - i=1 - DO j=1,ilptr(in) ! loop for positive diagonal elements - ! through all matrix elements - IF(ilptr(i) == j) THEN ! diagonal element - i=i+1 - ELSE - xi=MAX(xi,ABS(val(j))) ! Xi = abs(max) off-diagonal element - END IF - END DO - - delta=eps*MAX(1.0_mpd,dgamma+xi) - sn=1.0_mpd - IF(n > 1) sn=1.0_mpd/SQRT(REAL(n*n-1,mpd)) - beta=SQRT(MAX(eps,dgamma,xi*sn)) ! beta - WRITE(*,*) ' DELTA and BETA ',delta,beta - - DO k=2,n - mk=k-ilptr(k)+ilptr(k-1)+1 - - theta=0.0_mpd - - DO j=mk,k - mj=j-ilptr(j)+ilptr(j-1)+1 - kj=ilptr(k)-k+j ! index kj - - DO i=MAX(mj,mk),j-1 - val(kj)=val(kj) & ! L_kj := L_kj - L_ki D_ii L_ji - -val(ilptr(k)-k+i)*val(ilptr(i))*val(ilptr(j)-j+i) - - END DO ! - - theta=MAX(theta,ABS(val(kj))) ! maximum value of row - - IF(j /= k) THEN - IF(val(ilptr(j)) /= 0.0_mpd) THEN - val(kj)=val(kj)/val(ilptr(j)) - ELSE - val(kj)=0.0_mpd - END IF - END IF ! L_kj := L_kj/D_jj ! D_kk - - IF(j == k) THEN - valkj=val(kj) - IF(k <= in) THEN - val(kj)=MAX(ABS(val(kj)),(theta/beta)**2,delta) - IF(valkj /= val(kj)) THEN - WRITE(*,*) ' Index K=',k - WRITE(*,*) ' ',valkj,val(kj), (theta/beta)**2,delta,theta - END IF - END IF - END IF - END DO ! J - - END DO ! K - - DO k=1,n - IF(val(ilptr(k)) /= 0.0_mpd) val(ilptr(k))=1.0_mpd/val(ilptr(k)) - END DO - - RETURN -END SUBROUTINE vabdec - -!> Variable band matrix print minimum and maximum. -!! -!! \param [in] n size of matrix -!! \param [in,out] val variable-band matrix, replaced by D,L -!! \param [in] ilptr pointer array - -SUBROUTINE vabmmm(n,val,ilptr) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: k - INTEGER(mpi) :: kp - INTEGER(mpi) :: kr - INTEGER(mpi) :: ks - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN OUT) :: val(*) - INTEGER(mpi), INTENT(IN) :: ilptr(n) - kr=1 - ks=1 - kp=1 - DO k=1,n - IF(val(ilptr(k)) > val(ilptr(ks))) ks=k - IF(val(ilptr(k)) < val(ilptr(kr))) kr=k - IF(val(ilptr(k)) > 0.0.AND.val(ilptr(k)) < val(ilptr(kp))) kp=k - END DO - WRITE(*,*) ' Index value ',ks,val(ilptr(ks)) - WRITE(*,*) ' Index value ',kp,val(ilptr(kp)) - WRITE(*,*) ' Index value ',kr,val(ilptr(kr)) - - RETURN -END SUBROUTINE vabmmm - -!> Variable band matrix solution. -!! -!! The matrix equation A X = B is solved. The matrix is assumed to -!! decomposed before using VABDEC. The array X(N) contains on entry -!! the right-hand-side B(N); at return it contains the solution. -!! -!! \param [in] n size of matrix -!! \param [in,out] val decomposed variable-band matrix -!! \param [in] ilptr pointer array -!! \param [in,out] x r.h.s vector B, replaced by solution vector X - -SUBROUTINE vabslv(n,val,ilptr,x) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: j - INTEGER(mpi) :: k - INTEGER(mpi) :: mk - - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN OUT) :: val(*) - INTEGER(mpi), INTENT(IN) :: ilptr(n) - REAL(mpd), INTENT(IN OUT) :: x(n) - ! ... - DO k=1,n ! forward loop - mk=k-ilptr(k)+ilptr(k-1)+1 - DO j=mk,k-1 - x(k)=x(k)-val(ilptr(k)-k+j)*x(j) ! X_k := X_k - L_kj B_j - END DO - END DO ! K - - DO k=1,n ! divide by diagonal elements - x(k)=x(k)*val(ilptr(k)) ! X_k := X_k*D_kk - END DO - - DO k=n,1,-1 ! backward loop - mk=k-ilptr(k)+ilptr(k-1)+1 - DO j=mk,k-1 - x(j)=x(j)-val(ilptr(k)-k+j)*x(k) ! X_j := X_j - L_kj X_k - END DO - END DO ! K -END SUBROUTINE vabslv - -! matrix/vector products ------------------------------------------- - -!> Dot product. -!! -!! \param [in] n vector size -!! \param [in] dx vector -!! \param [in] dy vector -!! \return dot product dx*dy - -REAL(mpd) FUNCTION dbdot(n,dx,dy) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - REAL(mpd) :: dtemp - - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN) :: dx(*) - REAL(mpd), INTENT(IN) :: dy(*) - ! ... - dtemp=0.0_mpd - DO i = 1,MOD(n,5) - dtemp=dtemp+dx(i)*dy(i) - END DO - DO i =MOD(n,5)+1,n,5 - dtemp=dtemp+dx(i)*dy(i)+dx(i+1)*dy(i+1)+dx(i+2)*dy(i+2) & - +dx(i+3)*dy(i+3)+dx(i+4)*dy(i+4) - END DO - dbdot=dtemp -END FUNCTION dbdot - -!> Multiply, addition. -!! -!! Constant times vector added to a vector: DY:=DY+DA*DX -!! -!! \param [in] n vector size -!! \param [in] dx vector -!! \param [in,out] dy vector -!! \param [in] da scalar - -SUBROUTINE dbaxpy(n,da,dx,dy) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN) :: dx(*) - REAL(mpd), INTENT(IN OUT) :: dy(*) - REAL(mpd), INTENT(IN) :: da - ! ... - DO i=1,MOD(n,4) - dy(i)=dy(i)+da*dx(i) - END DO - DO i=MOD(n,4)+1,n,4 - dy(i )=dy(i )+da*dx(i ) - dy(i+1)=dy(i+1)+da*dx(i+1) - dy(i+2)=dy(i+2)+da*dx(i+2) - dy(i+3)=dy(i+3)+da*dx(i+3) - END DO -END SUBROUTINE dbaxpy - -!> Product symmetric matrix, vector. -!! -!! Multiply symmetric N-by-N matrix and N-vector. -!! -!! \param[in] v symmetric matrix -!! \param[in] a vector -!! \param[out] b vector B = V * A -!! \param[in] n size of matrix - -SUBROUTINE dbsvx(v,a,b,n) ! - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ij - INTEGER(mpi) :: ijs - INTEGER(mpi) :: j - - ! B := V * A - ! N N*N N - - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN) :: v(*) - REAL(mpd), INTENT(IN) :: a(*) - REAL(mpd), INTENT(OUT) :: b(*) - - REAL(mpd) :: dsum - ijs=1 - DO i=1,n - dsum=0.0 - ij=ijs - DO j=1,n - dsum=dsum+v(ij)*a(j) - IF(j < i) THEN - ij=ij+1 - ELSE - ij=ij+j - END IF - END DO - b(i)=dsum - ijs=ijs+i - END DO -END SUBROUTINE dbsvx - -!> Product LARGE symmetric matrix, vector. -!! -!! Multiply LARGE symmetric N-by-N matrix and N-vector: -!! -!! \param[in] v symmetric matrix -!! \param[in] a vector -!! \param[out] b product vector B = V * A -!! \param[in] n size of matrix - -SUBROUTINE dbsvxl(v,a,b,n) ! LARGE symm. matrix, vector - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: j - - ! B := V * A - ! N N*N N - - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN) :: v(*) - REAL(mpd), INTENT(IN) :: a(*) - REAL(mpd), INTENT(OUT) :: b(*) - - REAL(mpd) :: dsum - INTEGER(mpl) :: ij - INTEGER(mpl) :: ijs - ijs=1 - DO i=1,n - dsum=0.0 - ij=ijs - DO j=1,n - dsum=dsum+v(ij)*a(j) - IF(j < i) THEN - ij=ij+1 - ELSE - ij=ij+int8(j) - END IF - END DO - b(i)=dsum - ijs=ijs+int8(i) - END DO -END SUBROUTINE dbsvxl - -!> Multiply general M-by-N matrix A and N-vector X. -!! -!! \param [in] A general M-by-N matrix (A11 A12 ... A1N A21 A22 ...) -!! \param [in] X N vector -!! \param [out] Y = M vector -!! \param [in] M rows of A -!! \param [in] N columns of A - -SUBROUTINE dbgax(a,x,y,m,n) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ij - INTEGER(mpi) :: j - - REAL(mpd), INTENT(IN) :: a(*) - REAL(mpd), INTENT(IN) :: x(*) - REAL(mpd), INTENT(OUT) :: y(*) - INTEGER(mpi), INTENT(IN) :: m - INTEGER(mpi), INTENT(IN) :: n - - ! ... - ij=0 - DO i=1,m - y(i)=0.0_mpd - DO j=1,n - ij=ij+1 - y(i)=y(i)+a(ij)*x(j) - END DO - END DO -END SUBROUTINE dbgax - -!> A V AT product (similarity). -!! -!! Multiply symmetric N-by-N matrix from the left with general M-by-N -!! matrix and from the right with the transposed of the same general -!! matrix to form symmetric M-by-M matrix (used for error propagation). -!! -!! \param [in] V symmetric N-by-N matrix -!! \param [in] A general M-by-N matrix -!! \param [in,out] W symmetric M-by-M matrix -!! \param [in] MS rows of A (-rows: don't reset W) -!! \param [in] N columns of A -!! -SUBROUTINE dbavat(v,a,w,n,ms) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ij - INTEGER(mpi) :: ijs - INTEGER(mpi) :: il - INTEGER(mpi) :: j - INTEGER(mpi) :: jk - INTEGER(mpi) :: k - INTEGER(mpi) :: l - INTEGER(mpi) :: lk - INTEGER(mpi) :: lkl - INTEGER(mpi) :: m - - REAL(mpd), INTENT(IN) :: v(*) - REAL(mpd), INTENT(IN) :: a(*) - REAL(mpd), INTENT(INOUT) :: w(*) - INTEGER(mpi), INTENT(IN) :: n - INTEGER(mpi), INTENT(IN) :: ms - - REAL(mpd) :: cik - ! ... - m=ms - IF (m > 0) THEN - DO i=1,(m*m+m)/2 - w(i)=0.0_mpd ! reset output matrix - END DO - ELSE - m=-m - END IF - - il=-n - ijs=0 - DO i=1,m ! do I - ijs=ijs+i-1 ! - il=il+n ! - lkl=0 ! - DO k=1,n ! do K - cik=0.0_mpd ! - lkl=lkl+k-1 ! - lk=lkl ! - DO l=1,k ! do L - lk=lk+1 ! . - cik=cik+a(il+l)*v(lk) ! . - END DO ! end do L - DO l=k+1,n ! do L - lk=lk+l-1 ! . - cik=cik+a(il+l)*v(lk) ! . - END DO ! end do L - jk=k ! - ij=ijs ! - DO j=1,i ! do J - ij=ij+1 ! . - w(ij)=w(ij)+cik*a(jk) ! . - jk=jk+n ! . - END DO ! end do J - END DO ! end do K - END DO ! end do I -END SUBROUTINE dbavat - -!> Print symmetric matrix, vector. -!! -!! Prints the n-vector X and the symmetric N-by-N covariance matrix -!! V, the latter as a correlation matrix. -!! -!! \param[in] lun unit number -!! \param[in] x vector -!! \param[in] v symmetric matrix -!! \param[in] n size of matrix, vector - -SUBROUTINE dbmprv(lun,x,v,n) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ii - INTEGER(mpi) :: ij - INTEGER(mpi) :: j - INTEGER(mpi) :: jj - INTEGER(mpi) :: l - INTEGER(mpi) :: m - INTEGER(mpi) :: mc(15) - REAL(mps) :: pd - REAL(mps) :: rho - REAL(mps) :: err - - INTEGER(mpi), INTENT(IN) :: lun - REAL(mpd), INTENT(IN) :: x(*) - REAL(mpd), INTENT(IN) :: v(*) - INTEGER(mpi), INTENT(IN) :: n - - WRITE(lun,103) - WRITE(lun,101) - ii=0 - DO i=1,n - ij=ii - ii=ii+i - ERR=0.0 - IF(v(ii) > 0.0) ERR=SQRT(REAL(v(ii),mps)) - l=0 - jj=0 - DO j=1,i - jj=jj+j - ij=ij+1 - rho=0.0 - pd=REAL(v(ii)*v(jj),mps) - IF(pd > 0.0) rho=REAL(v(ij),mps)/SQRT(pd) - l=l+1 - mc(l)=NINT(100.0*ABS(rho),mpi) - IF(rho < 0.0) mc(l)=-mc(l) - IF(j == i.OR.l == 15) THEN - IF(j <= 15) THEN - IF(j == i) THEN - WRITE(lun,102) i,x(i),ERR,(mc(m),m=1,l-1) - ELSE - WRITE(lun,102) i,x(i),ERR,(mc(m),m=1,l) - END IF - ELSE - IF(j == i) THEN - WRITE(lun,103) (mc(m),m=1,l-1) - ELSE - WRITE(lun,103) (mc(m),m=1,l) - END IF - l=0 - END IF - END IF - END DO - END DO - WRITE(lun,104) - ! 100 RETURN - RETURN -101 FORMAT(9X,'Param',7X,'error',7X,'correlation coefficients'/) -102 FORMAT(1X,i5,2G12.4,1X,15I5) -103 FORMAT(31X,15I5) -104 FORMAT(33X,'(correlation coefficients in percent)') -END SUBROUTINE dbmprv - -!> Print symmetric matrix. -!! -!! Prints the symmetric N-by-N matrix V. -!! -!! \param[in] lun unit number -!! \param[in] v symmetric matrix -!! \param[in] n size of matrix, - -SUBROUTINE dbprv(lun,v,n) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi), PARAMETER :: istp=6 - INTEGER(mpi) :: i - INTEGER(mpi) :: ip - INTEGER(mpi) :: ipe - INTEGER(mpi) :: ipn - INTEGER(mpi) :: ips - INTEGER(mpi) :: k - - INTEGER(mpi), INTENT(IN) :: lun - REAL(mpd), INTENT(IN) :: v(*) - INTEGER(mpi), INTENT(IN) :: n - - WRITE(lun,101) - - DO i=1,n - ips=(i*i-i)/2 - ipe=ips+i - ip =ips -100 CONTINUE - ipn=ip+istp - WRITE(lun,102) i, ip+1-ips, (v(k),k=ip+1,MIN(ipn,ipe)) - IF (ipn < ipe) THEN - ip=ipn - GO TO 100 - END IF -END DO -RETURN -101 FORMAT(1X,'--- DBPRV -----------------------------------') -102 FORMAT(1X,2I3,6G12.4) -END SUBROUTINE dbprv - -! sort ------------------------------------------------------------- - -!> Heap sort direct (real). -!! -!! Real keys A(*), sorted at return. -!! -!! \param[in,out] a array of keys -!! \param[in] n number of keys - -SUBROUTINE heapf(a,n) - USE mpdef - - IMPLICIT NONE - ! - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: l - INTEGER(mpi) :: r - REAL(mps) :: at ! pivot key value - - REAL(mps), INTENT(IN OUT) :: a(*) - INTEGER(mpi), INTENT(IN) :: n - ! ... - IF(n <= 1) RETURN - l=n/2+1 - r=n -10 IF(l > 1) THEN - l=l-1 - at =a(l) - ELSE - at =a(r) - a(r)=a(1) - r=r-1 - IF(r == 1) THEN - a(1)=at - RETURN - END IF - END IF - i=l - j=l+l -20 IF(j <= r) THEN - IF(j < r) THEN - IF(a(j) < a(j+1)) j=j+1 - END IF - IF(at < a(j)) THEN - a(i)=a(j) - i=j - j=j+j - ELSE - j=r+1 - END IF - GO TO 20 - END IF - a(i)=at - GO TO 10 -END SUBROUTINE heapf - -!> Quick sort 1. -!! -!! Quick sort of A(1,N) integer. -!! -!! \param[in,out] a vector of integers, sorted at return -!! \param[in] n size of vector - -SUBROUTINE sort1k(a,n) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: nlev ! stack size - PARAMETER (nlev=2*32) ! ... for N = 2**32 = 4.3 10**9 - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: l - INTEGER(mpi) :: r - INTEGER(mpi) :: lev - INTEGER(mpi) :: lr(nlev) - INTEGER(mpi) :: lrh - INTEGER(mpi) :: maxlev - INTEGER(mpi) :: a1 ! pivot key - INTEGER(mpi) :: at ! pivot key - - INTEGER(mpi), INTENT(IN OUT) :: a(*) - INTEGER(mpi), INTENT(IN) :: n - ! ... - IF (n <= 0) RETURN - maxlev=0 - lev=0 - l=1 - r=n -10 IF(r-l == 1) THEN ! sort two elements L and R - IF(a(l) > a(r)) THEN - at=a(l) ! exchange L <-> R - a(l)=a(r) - a(r)=at - END IF - r=l - END IF - IF(r == l) THEN - IF(lev <= 0) THEN - ! WRITE(*,*) 'SORT1K (quicksort): maxlevel used/available =', - ! + MAXLEV,'/64' - RETURN - END IF - lev=lev-2 - l=lr(lev+1) - r=lr(lev+2) - ELSE - ! LRH=(L+R)/2 - lrh=(l/2)+(r/2) ! avoid bit overflow - IF(MOD(l,2) == 1.AND.MOD(r,2) == 1) lrh=lrh+1 - a1=a(lrh) ! middle - i=l-1 ! find limits [J,I] with [L,R] - j=r+1 -20 i=i+1 - IF(a(i) < a1) GO TO 20 -30 j=j-1 - IF(a(j) > a1) GO TO 30 - IF(i <= j) THEN - at=a(i) ! exchange I <-> J - a(i)=a(j) - a(j)=at - GO TO 20 - END IF - IF(lev+2 > nlev) THEN - CALL peend(33,'Aborted, stack overflow in quicksort') - STOP 'SORT1K (quicksort): stack overflow' - END IF - IF(r-i < j-l) THEN - lr(lev+1)=l - lr(lev+2)=j - l=i - ELSE - lr(lev+1)=i - lr(lev+2)=r - r=j - END IF - lev=lev+2 - maxlev=MAX(maxlev,lev) - END IF - GO TO 10 -END SUBROUTINE sort1k - -!> Quick sort 2. -!! -!! Quick sort of A(2,N) integer. -!! -!! \param[in,out] a vector (pair) of integers, sorted at return -!! \param[in] n size of vector - -SUBROUTINE sort2k(a,n) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: nlev ! stack size - PARAMETER (nlev=2*32) ! ... for N = 2**32 = 4.3 10**9 - INTEGER(mpi) :: i - INTEGER(mpi) ::j - INTEGER(mpi) ::l - INTEGER(mpi) ::r - INTEGER(mpi) ::lev - INTEGER(mpi) ::lr(nlev) - INTEGER(mpi) ::lrh - INTEGER(mpi) ::maxlev - INTEGER(mpi) ::a1 ! pivot key - INTEGER(mpi) ::a2 ! pivot key - INTEGER(mpi) ::at ! pivot key - - INTEGER(mpi), INTENT(IN OUT) :: a(2,*) - INTEGER(mpi), INTENT(IN) :: n - ! ... - maxlev=0 - lev=0 - l=1 - r=n -10 IF(r-l == 1) THEN ! sort two elements L and R - IF(a(1,l) > a(1,r).OR.( a(1,l) == a(1,r).AND.a(2,l) > a(2,r))) THEN - at=a(1,l) ! exchange L <-> R - a(1,l)=a(1,r) - a(1,r)=at - at=a(2,l) - a(2,l)=a(2,r) - a(2,r)=at - END IF - r=l - END IF - IF(r == l) THEN - IF(lev <= 0) THEN - WRITE(*,*) 'SORT2K (quicksort): maxlevel used/available =', maxlev,'/64' - RETURN - END IF - lev=lev-2 - l=lr(lev+1) - r=lr(lev+2) - ELSE - ! LRH=(L+R)/2 - lrh=(l/2)+(r/2) ! avoid bit overflow - IF(MOD(l,2) == 1.AND.MOD(r,2) == 1) lrh=lrh+1 - a1=a(1,lrh) ! middle - a2=a(2,lrh) - i=l-1 ! find limits [J,I] with [L,R] - j=r+1 -20 i=i+1 - IF(a(1,i) < a1) GO TO 20 - IF(a(1,i) == a1.AND.a(2,i) < a2) GO TO 20 -30 j=j-1 - IF(a(1,j) > a1) GO TO 30 - IF(a(1,j) == a1.AND.a(2,j) > a2) GO TO 30 - IF(i <= j) THEN - at=a(1,i) ! exchange I <-> J - a(1,i)=a(1,j) - a(1,j)=at - at=a(2,i) - a(2,i)=a(2,j) - a(2,j)=at - GO TO 20 - END IF - IF(lev+2 > nlev) THEN - CALL peend(33,'Aborted, stack overflow in quicksort') - STOP 'SORT2K (quicksort): stack overflow' - END IF - IF(r-i < j-l) THEN - lr(lev+1)=l - lr(lev+2)=j - l=i - ELSE - lr(lev+1)=i - lr(lev+2)=r - r=j - END IF - lev=lev+2 - maxlev=MAX(maxlev,lev) - END IF - GO TO 10 -END SUBROUTINE sort2k - -!> Quick sort 2 with index. -!! -!! Quick sort of A(3,N) integer. -!! -!! \param[in,out] a vector (pair) of integers, sorted at return and an index -!! \param[in] n size of vector - -SUBROUTINE sort2i(a,n) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: nlev ! stack size - PARAMETER (nlev=2*32) ! ... for N = 2**32 = 4.3 10**9 - INTEGER(mpi) :: i - INTEGER(mpi) ::j - INTEGER(mpi) ::l - INTEGER(mpi) ::r - INTEGER(mpi) ::lev - INTEGER(mpi) ::lr(nlev) - INTEGER(mpi) ::lrh - INTEGER(mpi) ::maxlev - INTEGER(mpi) ::a1 ! pivot key - INTEGER(mpi) ::a2 ! pivot key - INTEGER(mpi) ::at ! pivot key - - INTEGER(mpi), INTENT(IN OUT) :: a(3,*) - INTEGER(mpi), INTENT(IN) :: n - ! ... - maxlev=0 - lev=0 - l=1 - r=n -10 IF(r-l == 1) THEN ! sort two elements L and R - IF(a(1,l) > a(1,r).OR.( a(1,l) == a(1,r).AND.a(2,l) > a(2,r))) THEN - at=a(1,l) ! exchange L <-> R - a(1,l)=a(1,r) - a(1,r)=at - at=a(2,l) - a(2,l)=a(2,r) - a(2,r)=at - at=a(3,l) - a(3,l)=a(3,r) - a(3,r)=at - END IF - r=l - END IF - IF(r == l) THEN - IF(lev <= 0) THEN - WRITE(*,*) 'SORT2I (quicksort): maxlevel used/available =', maxlev,'/64' - RETURN - END IF - lev=lev-2 - l=lr(lev+1) - r=lr(lev+2) - ELSE - ! LRH=(L+R)/2 - lrh=(l/2)+(r/2) ! avoid bit overflow - IF(MOD(l,2) == 1.AND.MOD(r,2) == 1) lrh=lrh+1 - a1=a(1,lrh) ! middle - a2=a(2,lrh) - i=l-1 ! find limits [J,I] with [L,R] - j=r+1 -20 i=i+1 - IF(a(1,i) < a1) GO TO 20 - IF(a(1,i) == a1.AND.a(2,i) < a2) GO TO 20 -30 j=j-1 - IF(a(1,j) > a1) GO TO 30 - IF(a(1,j) == a1.AND.a(2,j) > a2) GO TO 30 - IF(i <= j) THEN - at=a(1,i) ! exchange I <-> J - a(1,i)=a(1,j) - a(1,j)=at - at=a(2,i) - a(2,i)=a(2,j) - a(2,j)=at - at=a(3,i) - a(3,i)=a(3,j) - a(3,j)=at - GO TO 20 - END IF - IF(lev+2 > nlev) THEN - CALL peend(33,'Aborted, stack overflow in quicksort') - STOP 'SORT2I (quicksort): stack overflow' - END IF - IF(r-i < j-l) THEN - lr(lev+1)=l - lr(lev+2)=j - l=i - ELSE - lr(lev+1)=i - lr(lev+2)=r - r=j - END IF - lev=lev+2 - maxlev=MAX(maxlev,lev) - END IF - GO TO 10 -END SUBROUTINE sort2i - -!> Chi2/ndf cuts. -!! -!! Return limit in Chi^2/ndf for N sigmas (N=1, 2 or 3). -!! -!! \param[in] n number of sigmas -!! \param[in] nd ndf -!! \return Chi2/ndf cut value - -REAL(mps) FUNCTION chindl(n,nd) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: m - INTEGER(mpi), INTENT(IN) :: n - INTEGER(mpi), INTENT(IN) :: nd - ! - REAL(mps) :: sn(3) - REAL(mps) ::table(30,3) - ! REAL PN(3) - ! DATA PN/0.31731,0.0455002785,2.69985E-3/ ! probabilities - DATA sn/0.47523,1.690140,2.782170/ - DATA table/ 1.0000, 1.1479, 1.1753, 1.1798, 1.1775, 1.1730, 1.1680, 1.1630, & - 1.1581, 1.1536, 1.1493, 1.1454, 1.1417, 1.1383, 1.1351, 1.1321, & - 1.1293, 1.1266, 1.1242, 1.1218, 1.1196, 1.1175, 1.1155, 1.1136, & - 1.1119, 1.1101, 1.1085, 1.1070, 1.1055, 1.1040, & - 4.0000, 3.0900, 2.6750, 2.4290, 2.2628, 2.1415, 2.0481, 1.9736, & - 1.9124, 1.8610, 1.8171, 1.7791, 1.7457, 1.7161, 1.6897, 1.6658, & - 1.6442, 1.6246, 1.6065, 1.5899, 1.5745, 1.5603, 1.5470, 1.5346, & - 1.5230, 1.5120, 1.5017, 1.4920, 1.4829, 1.4742, & - 9.0000, 5.9146, 4.7184, 4.0628, 3.6410, 3.3436, 3.1209, 2.9468, & - 2.8063, 2.6902, 2.5922, 2.5082, 2.4352, 2.3711, 2.3143, 2.2635, & - 2.2178, 2.1764, 2.1386, 2.1040, 2.0722, 2.0428, 2.0155, 1.9901, & - 1.9665, 1.9443, 1.9235, 1.9040, 1.8855, 1.8681/ - SAVE sn,table - ! ... - IF(nd < 1) THEN - chindl=0.0 - ELSE - m=MAX(1,MIN(n,3)) ! 1, 2 or 3 sigmas - IF(nd <= 30) THEN - chindl=table(nd,m) ! from table - ELSE ! approximation for ND > 30 - chindl=(sn(m)+SQRT(REAL(nd+nd-1,mps)))**2/REAL(nd+nd,mps) - END IF - END IF -END FUNCTION chindl - -!> LLT decomposition. -!! -!! Decomposition: C = L L^T. -!! -!! Variable-band matrix row-Doolittle decomposition of pos. def. matrix. -!! A variable-band NxN symmetric matrix, is stored row by row in the -!! array C(.). For each row all coefficients from the first -!! non-zero element in the row to the diagonal is stored. -!! The pointer array INDIA(N) contains the indices in C(.) of the -!! diagonal elements. INDIA(1) is always 1, and INDIA(N) is equal -!! to the total number of coefficients stored, called the profile. -!! The form of a variable-band matrix is preserved in the L D L^T -!! decomposition. No fill-in is created ahead in any row or ahead of the -!! first entry in any column, but existing zero-values will become -!! non-zero. The decomposition is done "in-place". -!! (The diagonal will contain the inverse of the diaginal of L). -!! -!! - NRKD = 0 no component removed -!! -!! - NRKD < 0 1 component removed, negative index -!! -!! - NRKD > 1 number of -!! -!! The matrix C is assumed to be positive definite, e.g. from the -!! normal equations of least squares. The (positive) diagonal elements -!! are reduced during decomposition. If a diagonal element is reduced -!! by about a word length (see line "test for linear dependence"), -!! then the pivot is assumed as zero and the entire row/column is -!! reset to zero, removing the corresponding element from the solution. -!! Optionally use only diagonal element in this case to preserve rank -!! (changing band to skyline matrix). -!! -!! \param [in] n size of matrix -!! \param [in,out] c variable-band matrix, replaced by L -!! \param [in] india pointer array -!! \param [out] nrkd removed components -!! \param [in] iopt >0: use diagonal to preserve rank ('skyline') - -SUBROUTINE lltdec(n,c,india,nrkd,iopt) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: k - INTEGER(mpi) :: kj - INTEGER(mpi) :: mj - INTEGER(mpi) :: mk - REAL(mpd) ::diag - - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN OUT) :: c(*) - INTEGER(mpi), INTENT(IN) :: india(n) - INTEGER(mpi), INTENT(OUT) :: nrkd - INTEGER(mpi), INTENT(IN) :: iopt - REAL(mpd) eps - ! ... - eps = 16.0_mpd * epsilon(eps) ! 16 * precision(mpd) - - ! .. - nrkd=0 - diag=0.0_mpd - IF(c(india(1)) > 0.0) THEN - c(india(1))=1.0_mpd/SQRT(c(india(1))) ! square root - ELSE - c(india(1))=0.0_mpd - nrkd=-1 - END IF - - DO k=2,n - mk=k-india(k)+india(k-1)+1 ! first index in row K - DO j=mk,k ! loop over row K with index J - mj=1 - IF(j > 1) mj=j-india(j)+india(j-1)+1 ! first index in row J - kj=india(k)-k+j ! index kj - diag=c(india(j)) ! j-th diagonal element - - DO i=MAX(mj,mk),j-1 - ! L_kj = L_kj - L_ki *D_ii *L_ji - c(kj)=c(kj) - c(india(k)-k+i)*c(india(j)-j+i) - END DO ! I - - IF(j /= k) c(kj)=c(kj)*diag - END DO ! J - - IF(c(india(k)) > eps*diag) THEN ! test for linear dependence - c(india(k))=1.0_mpd/SQRT(c(india(k))) ! square root - ELSE - DO j=mk,k ! reset row K - c(india(k)-k+j)=0.0_mpd - END DO ! J - IF (iopt > 0 .and. diag > 0.0) THEN ! skyline - c(india(k))=1.0_mpd/SQRT(diag) ! square root - ELSE - IF(nrkd == 0) THEN - nrkd=-k - ELSE - IF(nrkd < 0) nrkd=1 - nrkd=nrkd+1 - END IF - END IF - END IF - - END DO ! K - RETURN -END SUBROUTINE lltdec - - -!> Forward solution. -!! -!! The matrix equation A X = B is solved by forward + backward -!! solution. The matrix is assumed to -!! decomposed before using LLTDEC. The array X(N) contains on entry -!! the right-hand-side B(N); at return it contains the solution. -!! -!! \param [in] n size of matrix -!! \param [in,out] c decomposed variable-band matrix -!! \param [in] india pointer array -!! \param [in,out] x r.h.s vector B, replaced by solution vector X - -SUBROUTINE lltfwd(n,c,india,x) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: j - INTEGER(mpi) :: k - - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN) :: c(*) - INTEGER(mpi), INTENT(IN) :: india(n) - REAL(mpd), INTENT(IN OUT) :: x(n) - - x(1)=x(1)*c(india(1)) - DO k=2,n ! forward loop - DO j=k-india(k)+india(k-1)+1,k-1 - x(k)=x(k)-c(india(k)-k+j)*x(j) ! X_k := X_k - L_kj * B_j - END DO ! J - x(k)=x(k)*c(india(k)) - END DO ! K - - RETURN -END SUBROUTINE lltfwd - -!> Backward solution. -!! -!! The matrix equation A X = B is solved by forward + backward -!! solution. The matrix is assumed to -!! decomposed before using LLTDEC. The array X(N) contains on entry -!! the right-hand-side B(N); at return it contains the solution. -!! -!! \param [in] n size of matrix -!! \param [in,out] c decomposed variable-band matrix -!! \param [in] india pointer array -!! \param [in,out] x r.h.s vector B, replaced by solution vector X - -SUBROUTINE lltbwd(n,c,india,x) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: j - INTEGER(mpi) :: k - - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN) :: c(*) - INTEGER(mpi), INTENT(IN) :: india(n) - REAL(mpd), INTENT(IN OUT) :: x(n) - - DO k=n,2,-1 ! backward loop - x(k)=x(k)*c(india(k)) - DO j=k-india(k)+india(k-1)+1,k-1 - x(j)=x(j)-c(india(k)-k+j)*x(k) ! X_j := X_j - L_kj * X_k - END DO ! J - END DO ! K - x(1)=x(1)*c(india(1)) - - RETURN -END SUBROUTINE lltbwd - -!> Decomposition of equilibrium systems. -!! -!! N x N matrix C: starting with sym.pos.def. matrix (N) -!! length of array C: INDIA(N) + N*M + (M*M+M)/2 -!! Content of array C: band matrix, as described by INDIA(1)...INDIA(N) -!! followed by: NxM elements of constraint matrix A -!! followed by: (M*M+M)/2 unused elements -!! INDIA(N+1)...INDIA(N+M) defined internally -!! -!! \param [in] n size of symmetric matrix -!! \param [in] m number of constrains -!! \param [in] ls flag for skyline decomposition -!! \param [in,out] c combined variable-band + constraints matrix, replaced by decomposition -!! \param [in,out] india pointer array -!! \param [out] nrkd removed components -!! \param [out] nrkd2 removed components -!! -SUBROUTINE equdec(n,m,ls,c,india,nrkd,nrkd2) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: jk - INTEGER(mpi) :: k - - INTEGER(mpi), INTENT(IN) :: n - INTEGER(mpi), INTENT(IN) :: m - INTEGER(mpi), INTENT(IN) :: ls - REAL(mpd), INTENT(IN OUT) :: c(*) - INTEGER(mpi), INTENT(IN OUT) :: india(n+m) - INTEGER(mpi), INTENT(OUT) :: nrkd - INTEGER(mpi), INTENT(OUT) :: nrkd2 - - ! ... - - nrkd=0 - nrkd2=0 - - CALL lltdec(n,c,india,nrkd,ls) ! decomposition G G^T - - IF (m>0) THEN - DO i=1,m - CALL lltfwd(n,c,india,c(india(n)+(i-1)*n+1)) ! forward solution K - END DO - - jk=india(n)+n*m - DO j=1,m - DO k=1,j - jk=jk+1 - c(jk)=0.0_mpd ! product K K^T - DO i=1,n - c(jk)=c(jk)+c(india(n)+(j-1)*n+i)*c(india(n)+(k-1)*n+i) - END DO - END DO - END DO - - india(n+1)=1 - DO i=2,m - india(n+i)=india(n+i-1)+MIN(i,m) ! pointer for K K^T - END DO - - CALL lltdec(m,c(india(n)+n*m+1),india(n+1),nrkd2,0) ! decomp. H H^T - ENDIF - - RETURN -END SUBROUTINE equdec - -!> Solution of equilibrium systems (after decomposition). -!! -!! N x N matrix C: starting with sym.pos.def. matrix (N) -!! length of array C: INDIA(N) + N*M + (M*M+M)/2 -!! Content of array C: band matrix, as described by INDIA(1)...INDIA(N) -!! followed by: NxM elements of constraint matrix A -!! followed by: (M*M+M)/2 unused elements -!! INDIA(N+1)...INDIA(N+M) defined internally -!! -!! \param [in] n size of symmetric matrix -!! \param [in] m number of constrains -!! \param [in] c decomposed combined variable-band + constraints matrix -!! \param [in] india pointer array -!! \param [in,out] x r.h.s vector B, replaced by solution vector X -!! -SUBROUTINE equslv(n,m,c,india,x) ! solution vector - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: j - - INTEGER(mpi), INTENT(IN) :: n - INTEGER(mpi), INTENT(IN) :: m - REAL(mpd), INTENT(IN) :: c(*) - INTEGER(mpi), INTENT(IN) :: india(n+m) - REAL(mpd), INTENT(IN OUT) :: x(n+m) - - CALL lltfwd(n,c,india,x) ! result is u - - IF (m>0) THEN - DO i=1,m - DO j=1,n - x(n+i)=x(n+i)-x(j)*c(india(n)+(i-1)*n+j) ! g - K u - END DO - END DO - CALL lltfwd(m,c(india(n)+n*m+1),india(n+1),x(n+1)) ! result is v - - - CALL lltbwd(m,c(india(n)+n*m+1),india(n+1),x(n+1)) ! result is -y - DO i=1,m - x(n+i)=-x(n+i) ! result is +y - END DO - - DO i=1,n - DO j=1,m - x(i)=x(i)-x(n+j)*c(india(n)+(j-1)*n+i) ! u - K^T y - END DO - END DO - ENDIF - - CALL lltbwd(n,c,india,x) ! result is x - - RETURN -END SUBROUTINE equslv - -!> Constrained preconditioner, decomposition. -!! -!! Constrained preconditioner, e.g for GMRES solution: -!! -!! intermediate -!! ( ) ( ) ( ) ( ) -!! ( C A^T ) ( x ) = ( y ) ( u ) -!! ( ) ( ) ( ) ( ) -!! ( A 0 ) ( l ) ( d ) ( v ) -!! -!! input: -!! C(N) is diagonal matrix and remains unchanged -!! may be identical to CU(N), then it is changed -!! A(N,P) is modified -!! Y(N+P) is rhs vector, unchanged -!! may be identical to X(N), then it is changed -!! -!! result: -!! CU(N) is 1/sqrt of diagonal matrix C(N) -!! X(N+P) is result vector -!! S((P*P+P)/2) is Cholesky decomposed symmetric (P,P) matrix -!! -!! \param [in] p number of constraints -!! \param [in] n size of diagonal matrix -!! \param [in] c diagonal matrix (changed if c=cu as actual parameters) -!! \param [out] cu 1/sqrt(c) -!! \param [in,out] a constraint matrix (size n*p), modified -!! \param [out] s Cholesky decomposed symmetric (P,P) matrix -!! \param [out] nrkd removed components - -SUBROUTINE precon(p,n,c,cu,a,s,nrkd) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ii - INTEGER(mpi) :: j - INTEGER(mpi) :: jj - INTEGER(mpi) :: jk - INTEGER(mpi) :: k - INTEGER(mpi) :: kk - - INTEGER(mpi), INTENT(IN) :: p - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN) :: c(n) - REAL(mpd), INTENT(OUT) :: cu(n) - REAL(mpd), INTENT(IN OUT) :: a(n,p) - REAL(mpd), INTENT(OUT) :: s((p*p+p)/2) - INTEGER(mpi), INTENT(OUT) :: nrkd - - REAL(mpd) :: div - REAL(mpd) :: ratio - - nrkd=0 - DO i=1,(p*p+p)/2 - s(i)=0.0_mpd - END DO - DO i=1,n - jk=0 - div=c(i) ! copy - IF (div > 0.0_mpd) THEN - cu(i)=1.0_mpd/SQRT(div) - ELSE - cu(i)=0.0_mpd - nrkd=nrkd+1 - END IF - DO j=1,p - a(i,j)=a(i,j)*cu(i) ! K = A C^{-1/2} - DO k=1,j - jk=jk+1 - s(jk)=s(jk)+a(i,j)*a(i,k) ! S = symmetric matrix K K^T - END DO - END DO - END DO - - ii=0 - DO i=1,p ! S -> H D H^T (Cholesky) - ii=ii+i - IF(s(ii) /= 0.0_mpd) s(ii)=1.0_mpd/s(ii) - jj=ii - DO j=i+1,p - ratio=s(i+jj)*s(ii) - kk=jj - DO k=j,p - s(kk+j)=s(kk+j)-s(kk+i)*ratio - kk=kk+k - END DO ! K - s(i+jj)=ratio - jj=jj+j - END DO ! J - END DO ! I - RETURN -END SUBROUTINE precon - -!> Constrained preconditioner, solution. -!! -!! \param [in] p number of constraints -!! \param [in] n size of diagonal matrix -!! \param [in] cu 1/sqrt(c) -!! \param [in] a modified constraint matrix (size n*p) -!! \param [in] s Cholesky decomposed symmetric (P,P) matrix -!! \param [out] x result vector -!! \param [in] y rhs vector (changed if x=y as actual parameters) - -SUBROUTINE presol(p,n,cu,a,s,x,y) ! solution - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: jj - INTEGER(mpi) :: k - INTEGER(mpi) :: kk - - INTEGER(mpi), INTENT(IN) :: p - INTEGER(mpi), INTENT(IN) :: n - - REAL(mpd), INTENT(IN) :: cu(n) - REAL(mpd), INTENT(IN) :: a(n,p) - REAL(mpd), INTENT(IN) :: s((p*p+p)/2) - REAL(mpd), INTENT(OUT) :: x(n+p) - REAL(mpd), INTENT(IN) :: y(n+p) - - REAL(mpd) :: dsum - - DO i=1,n+p - x(i)=y(i) - END DO - DO i=1,n - x(i)=x(i)*cu(i) ! u =C^{-1/2} y - DO j=1,p - x(n+j)=x(n+j)-a(i,j)*x(i) ! d - K u - END DO - END DO - - jj=0 - DO j=1,p ! Cholesky solution for v - dsum=x(n+j) - DO k=1,j-1 - dsum=dsum-s(k+jj)*x(n+k) ! H v = d - K u - END DO - x(n+j)=dsum ! -> v - jj=jj+j - END DO - - DO j=p,1,-1 ! solution for lambda - dsum=x(n+j)*s(jj) - kk=jj - DO k=j+1,p - dsum=dsum+s(kk+j)*x(n+k) ! D H^T lambda = -v - kk=kk+k - END DO - x(n+j)=-dsum ! -> lambda - jj=jj-j - END DO - - DO i=1,n ! u - K^T lambda - DO j=1,p - x(i)=x(i)-a(i,j)*x(n+j) - END DO - END DO - DO i=1,n - x(i)=x(i)*cu(i) ! x = C^{-1/2} u - END DO - -END SUBROUTINE presol - - -! 090817 C. Kleinwort, DESY-FH1 -!> Bordered band matrix. -!! -!! Obtain solution of a system of linear equations with symmetric -!! bordered band matrix (V * X = B), on request inverse is calculated. -!! For band part root-free Cholesky decomposition and forward/backward -!! substitution is used. -!! -!! Use decomposition in border and band part for block matrix algebra: -!! -!! | A Ct | | x1 | | b1 | , A is the border part -!! | | * | | = | | , Ct is the mixed part -!! | C D | | x2 | | b2 | , D is the band part -!! -!! Explicit inversion of D is avoided by using solution X of D*X=C (X=D^-1*C, -!! obtained from Cholesky decomposition and forward/backward substitution) -!! -!! | x1 | | E*b1 - E*Xt*b2 | , E^-1 = A-Ct*D^-1*C = A-Ct*X -!! | | = | | -!! | x2 | | x - X*x1 | , x is solution of D*x=b2 (x=D^-1*b2) -!! -!! Inverse matrix is: -!! -!! | E -E*Xt | -!! | | , only band part of (D^-1 + X*E*Xt) -!! | -X*E D^-1 + X*E*Xt | is calculated for inv=1 -!! -!! \param [in,out] v symmetric N-by-N matrix in symmetric storage mode -!! (V(1) = V11, V(2) = V12, V(3) = V22, V(4) = V13, ...), -!! replaced by inverse matrix -!! \param [in,out] b N-vector, replaced by solution vector -!! \param [in] n size of V, B -!! \param [in] nbdr border size -!! \param [in] nbnd band width -!! \param [in] inv =1 calculate band part of inverse (for pulls), -!! >1 calculate complete inverse -!! \param [out] nrank rank of matrix V -!! \param [out] vbnd band part of V -!! \param [out] vbdr border part of V -!! \param [out] aux solutions for border rows -!! \param [out] vbk matrix for border solution -!! \param [out] vzru border solution -!! \param [out] scdiag workspace (D) -!! \param [out] scflag workspace (I) -!! -SUBROUTINE sqmibb(v,b,n,nbdr,nbnd,inv,nrank,vbnd,vbdr,aux,vbk,vzru,scdiag,scflag) - USE mpdef - - ! REAL(mpd) scratch arrays: - ! VBND(N*(NBND+1)) = storage of band part - ! VBDR(N* NBDR) = storage of border part - ! AUX (N* NBDR) = intermediate results - - ! cost[dot ops] ~= (N-NBDR)*(NBDR+NBND+1)**2 + NBDR**3/3 (leading term, solution only) - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ib - INTEGER(mpi) :: ij - INTEGER(mpi) :: ioff - INTEGER(mpi) :: ip - INTEGER(mpi) :: ip1 - INTEGER(mpi) :: ip2 - INTEGER(mpi) :: is - INTEGER(mpi) :: j - INTEGER(mpi) :: j0 - INTEGER(mpi) :: jb - INTEGER(mpi) :: joff - INTEGER(mpi) :: mp1 - INTEGER(mpi) :: nb1 - INTEGER(mpi) :: nmb - INTEGER(mpi) :: npri - INTEGER(mpi) :: nrankb - - REAL(mpd), INTENT(IN OUT) :: v(*) - REAL(mpd), INTENT(OUT) :: b(n) - INTEGER(mpi), INTENT(IN) :: n - INTEGER(mpi), INTENT(IN) :: nbdr - INTEGER(mpi), INTENT(IN) :: nbnd - INTEGER(mpi), INTENT(IN) :: inv - INTEGER(mpi), INTENT(OUT) :: nrank - - REAL(mpd), INTENT(OUT) :: vbnd(n*(nbnd+1)) - REAL(mpd), INTENT(OUT) :: vbdr(n*nbdr) - REAL(mpd), INTENT(OUT) :: aux(n*nbdr) - REAL(mpd), INTENT(OUT) :: vbk((nbdr*nbdr+nbdr)/2) - REAL(mpd), INTENT(OUT) :: vzru(nbdr) - REAL(mpd), INTENT(OUT) :: scdiag(nbdr) - INTEGER(mpi), INTENT(OUT) :: scflag(nbdr) - - SAVE npri - DATA npri / 100 / - ! ... - nrank=0 - nb1=nbdr+1 - mp1=nbnd+1 - nmb=n-nbdr - ! copy band part - DO i=nb1,n - ip=(i*(i+1))/2 - is=0 - DO j=i,MIN(n,i+nbnd) - ip=ip+is - is=j - ib=j-i+1 - vbnd(ib+(i-nb1)*mp1)=v(ip) - END DO - END DO - ! copy border part - IF (nbdr > 0) THEN - ioff=0 - DO i=1,nbdr - ip=(i*(i+1))/2 - is=0 - DO j=i,n - ip=ip+is - is=j - vbdr(ioff+j)=v(ip) - END DO - ioff=ioff+n - END DO - END IF - - CALL dbcdec(vbnd,mp1,nmb,aux) - ! use? CALL DBFDEC(VBND,MP1,NMB) ! modified decomp., numerically more stable - ! CALL DBCPRB(VBND,MP1,NMB) - ip=1 - DO i=1, nmb - IF (vbnd(ip) <= 0.0_mpd) THEN - npri=npri-1 - IF (npri >= 0) THEN - IF (vbnd(ip) == 0.0_mpd) THEN - PRINT *, ' SQMIBB matrix singular', n, nbdr, nbnd - ELSE - PRINT *, ' SQMIBB matrix not positive definite', n, nbdr, nbnd - END IF - END IF - ! return zeros - DO ip=1,n - b(ip)=0.0_mpd - END DO - DO ip=1,(n*n+n)/2 - v(ip)=0.0_mpd - END DO - RETURN - END IF - ip=ip+mp1 - END DO - nrank=nmb - - IF (nbdr == 0) THEN ! special case NBDR=0 - - CALL dbcslv(vbnd,mp1,nmb,b,b) - IF (inv > 0) THEN - IF (inv > 1) THEN - CALL dbcinv(vbnd,mp1,nmb,v) - ELSE - CALL dbcinb(vbnd,mp1,nmb,v) - END IF - END IF - - ELSE ! general case NBDR>0 - - ioff=nb1 - DO ib=1,nbdr - ! solve for aux. vectors - CALL dbcslv(vbnd,mp1,nmb,vbdr(ioff),aux(ioff)) - ! zT ru - vzru(ib)=b(ib) - DO i=0,nmb-1 - vzru(ib)=vzru(ib)-b(nb1+i)*aux(ioff+i) - END DO - ioff=ioff+n - END DO - ! solve for band part only - CALL dbcslv(vbnd,mp1,nmb,b(nb1),b(nb1)) - ! Ck - cT z - ip=0 - ioff=nb1 - DO ib=1,nbdr - joff=nb1 - DO jb=1,ib - ip=ip+1 - vbk(ip)=v(ip) - DO i=0,nmb-1 - vbk(ip)=vbk(ip)-vbdr(ioff+i)*aux(joff+i) - END DO - joff=joff+n - END DO - ioff=ioff+n - END DO - ! solve border part - CALL sqminv(vbk,vzru,nbdr,nrankb,scdiag,scflag) - IF (nrankb == nbdr) THEN - nrank=nrank+nbdr - ELSE - npri=npri-1 - IF (npri >= 0) PRINT *, ' SQMIBB undef border ', n, nbdr, nbnd, nrankb - DO ib=1,nbdr - vzru(ib)=0.0_mpd - END DO - DO ip=(nbdr*nbdr+nbdr)/2,1,-1 - vbk(ip)=0.0_mpd - END DO - END IF - ! smoothed data points - ioff=nb1 - DO ib=1, nbdr - b(ib) = vzru(ib) - DO i=0,nmb-1 - b(nb1+i)=b(nb1+i)-b(ib)*aux(ioff+i) - END DO - ioff=ioff+n - END DO - ! inverse requested ? - IF (inv > 0) THEN - IF (inv > 1) THEN - CALL dbcinv(vbnd,mp1,nmb,v) - ELSE - CALL dbcinb(vbnd,mp1,nmb,v) - END IF - ! expand/correct from NMB to N - ip1=(nmb*nmb+nmb)/2 - ip2=(n*n+n)/2 - DO i=nmb-1,0,-1 - j0=0 - IF (inv == 1) j0=MAX(0,i-nbnd) - DO j=i,j0,-1 - v(ip2)=v(ip1) - ioff=nb1 - DO ib=1,nbdr - joff=nb1 - DO jb=1,nbdr - ij=MAX(ib,jb) - ij=(ij*ij-ij)/2+MIN(ib,jb) - v(ip2)=v(ip2)+vbk(ij)*aux(ioff+i)*aux(joff+j) - joff=joff+n - END DO - ioff=ioff+n - END DO - ip1=ip1-1 - ip2=ip2-1 - END DO - ip1=ip1-j0 - ip2=ip2-j0 - - DO ib=nbdr,1,-1 - v(ip2)=0.0_mpd - joff=nb1 - DO jb=1,nbdr - ij=MAX(ib,jb) - ij=(ij*ij-ij)/2+MIN(ib,jb) - v(ip2)=v(ip2)-vbk(ij)*aux(i+joff) - joff=joff+n - END DO - ip2=ip2-1 - END DO - END DO - - DO ip=(nbdr*nbdr+nbdr)/2,1,-1 - v(ip2)=vbk(ip) - ip2=ip2-1 - END DO - - END IF - END IF - -END SUBROUTINE sqmibb - -! 181105 C. Kleinwort, DESY-BELLE -!> Band bordered matrix. -!! -!! Obtain solution of a system of linear equations with symmetric -!! band bordered matrix (V * X = B), on request inverse is calculated. -!! For band part root-free Cholesky decomposition and forward/backward -!! substitution is used. -!! -!! Use decomposition in band and border part for block matrix algebra: -!! -!! | A Ct | | x1 | | b1 | , A is the band part -!! | | * | | = | | , Ct is the mixed part -!! | C D | | x2 | | b2 | , D is the border part -!! -!! \param [in,out] v symmetric N-by-N matrix in symmetric storage mode -!! (V(1) = V11, V(2) = V12, V(3) = V22, V(4) = V13, ...), -!! replaced by inverse matrix -!! \param [in,out] b N-vector, replaced by solution vector -!! \param [in] n size of V, B -!! \param [in] nbdr border size -!! \param [in] nbnd band width -!! \param [in] inv =1 calculate band part of inverse (for pulls), -!! >1 calculate complete inverse -!! \param [out] nrank rank of matrix V -!! \param [out] vbnd band part of V -!! \param [out] vbdr border part of V -!! \param [out] aux solutions for border rows -!! \param [out] vbk matrix for border solution -!! \param [out] vzru border solution -!! \param [out] scdiag workspace (D) -!! \param [out] scflag workspace (I) -!! -SUBROUTINE sqmibb2(v,b,n,nbdr,nbnd,inv,nrank,vbnd,vbdr,aux,vbk,vzru,scdiag,scflag) - USE mpdef - - ! REAL(mpd) scratch arrays: - ! VBND(N*(NBND+1)) = storage of band part - ! VBDR(N* NBDR) = storage of border part - ! AUX (N* NBDR) = intermediate results - - ! cost[dot ops] ~= (N-NBDR)*(NBDR+NBND+1)**2 + NBDR**3/3 (leading term, solution only) - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ib - INTEGER(mpi) :: ij - INTEGER(mpi) :: ioff - INTEGER(mpi) :: ip - INTEGER(mpi) :: ip1 - INTEGER(mpi) :: is - INTEGER(mpi) :: j - INTEGER(mpi) :: j0 - INTEGER(mpi) :: jb - INTEGER(mpi) :: joff - INTEGER(mpi) :: koff - INTEGER(mpi) :: mp1 - INTEGER(mpi) :: nb1 - INTEGER(mpi) :: nmb - INTEGER(mpi) :: npri - INTEGER(mpi) :: nrankb - - REAL(mpd), INTENT(IN OUT) :: v(*) - REAL(mpd), INTENT(OUT) :: b(n) - INTEGER(mpi), INTENT(IN) :: n - INTEGER(mpi), INTENT(IN) :: nbdr - INTEGER(mpi), INTENT(IN) :: nbnd - INTEGER(mpi), INTENT(IN) :: inv - INTEGER(mpi), INTENT(OUT) :: nrank - - REAL(mpd), INTENT(OUT) :: vbnd(n*(nbnd+1)) - REAL(mpd), INTENT(OUT) :: vbdr(n*nbdr) - REAL(mpd), INTENT(OUT) :: aux(n*nbdr) - REAL(mpd), INTENT(OUT) :: vbk((nbdr*nbdr+nbdr)/2) - REAL(mpd), INTENT(OUT) :: vzru(nbdr) - REAL(mpd), INTENT(OUT) :: scdiag(nbdr) - INTEGER(mpi), INTENT(OUT) :: scflag(nbdr) - - SAVE npri - DATA npri / 100 / - ! ... - nrank=0 - mp1=nbnd+1 - nmb=n-nbdr - nb1=nmb+1 - ! copy band part - DO i=1,nmb - ip=(i*(i+1))/2 - is=0 - DO j=i,MIN(nmb,i+nbnd) - ip=ip+is - is=j - ib=j-i+1 - vbnd(ib+(i-1)*mp1)=v(ip) - END DO - END DO - ! copy border part - IF (nbdr > 0) THEN - ioff=0 - DO i=nb1,n - ip=(i*(i-1))/2 - DO j=1,i - vbdr(ioff+j)=v(ip+j) - END DO - ioff=ioff+n - END DO - END IF - - CALL dbcdec(vbnd,mp1,nmb,aux) - ! use? CALL DBFDEC(VBND,MP1,NMB) ! modified decomp., numerically more stable - ! CALL DBCPRB(VBND,MP1,NMB) - ip=1 - DO i=1, nmb - IF (vbnd(ip) <= 0.0_mpd) THEN - npri=npri-1 - IF (npri >= 0) THEN - IF (vbnd(ip) == 0.0_mpd) THEN - PRINT *, ' SQMIBB2 matrix singular', n, nbdr, nbnd - ELSE - PRINT *, ' SQMIBB2 matrix not positive definite', n, nbdr, nbnd - END IF - END IF - ! return zeros - DO ip=1,n - b(ip)=0.0_mpd - END DO - DO ip=1,(n*n+n)/2 - v(ip)=0.0_mpd - END DO - RETURN - END IF - ip=ip+mp1 - END DO - nrank=nmb - - IF (nbdr == 0) THEN ! special case NBDR=0 - - CALL dbcslv(vbnd,mp1,nmb,b,b) - IF (inv > 0) THEN - IF (inv > 1) THEN - CALL dbcinv(vbnd,mp1,nmb,v) - ELSE - CALL dbcinb(vbnd,mp1,nmb,v) - END IF - END IF - - ELSE ! general case NBDR>0 - - ioff=0 - DO ib=1,nbdr - ! solve for aux. vectors - CALL dbcslv(vbnd,mp1,nmb,vbdr(ioff+1),aux(ioff+1)) - ! zT ru - vzru(ib)=b(nmb+ib) - DO i=1,nmb - vzru(ib)=vzru(ib)-b(i)*aux(ioff+i) - END DO - ioff=ioff+n - END DO - ! solve for band part only - CALL dbcslv(vbnd,mp1,nmb,b,b) - ! Ck - cT z - ip=0 - ioff=0 - koff=nmb - DO ib=1,nbdr - joff=0 - DO jb=1,ib - ip=ip+1 - vbk(ip)=vbdr(koff+jb) - DO i=1,nmb - vbk(ip)=vbk(ip)-vbdr(ioff+i)*aux(joff+i) - END DO - joff=joff+n - END DO - ioff=ioff+n - koff=koff+n - END DO - - ! solve border part - CALL sqminv(vbk,vzru,nbdr,nrankb,scdiag,scflag) - IF (nrankb == nbdr) THEN - nrank=nrank+nbdr - ELSE - npri=npri-1 - IF (npri >= 0) PRINT *, ' SQMIBB2 undef border ', n, nbdr, nbnd, nrankb - DO ib=1,nbdr - vzru(ib)=0.0_mpd - END DO - DO ip=(nbdr*nbdr+nbdr)/2,1,-1 - vbk(ip)=0.0_mpd - END DO - END IF - ! smoothed data points - ioff=0 - DO ib=1, nbdr - DO i=1,nmb - b(i)=b(i)-vzru(ib)*aux(ioff+i) - END DO - ioff=ioff+n - b(nmb+ib)=vzru(ib) - END DO - ! inverse requested ? - IF (inv > 0) THEN - IF (inv > 1) THEN - CALL dbcinv(vbnd,mp1,nmb,v) - ELSE - CALL dbcinb(vbnd,mp1,nmb,v) - END IF - ! assemble band and border - IF (nbdr > 0) THEN - ! band part - ip1=(nmb*nmb+nmb)/2 - DO i=nmb-1,0,-1 - j0=0 - IF (inv == 1) j0=MAX(0,i-nbnd) - DO j=i,j0,-1 - ioff=1 - DO ib=1,nbdr - joff=1 - DO jb=1,nbdr - ij=MAX(ib,jb) - ij=(ij*ij-ij)/2+MIN(ib,jb) - v(ip1)=v(ip1)+vbk(ij)*aux(ioff+i)*aux(joff+j) - joff=joff+n - END DO - ioff=ioff+n - END DO - ip1=ip1-1 - END DO - ip1=ip1-j0 - END DO - ! border part - ip1=(nmb*nmb+nmb)/2 - ip=0 - DO ib=1,nbdr - DO i=1,nmb - ip1=ip1+1 - v(ip1)=0.0_mpd - joff=0 - DO jb=1,nbdr - ij=MAX(ib,jb) - ij=(ij*ij-ij)/2+MIN(ib,jb) - v(ip1)=v(ip1)-vbk(ij)*aux(i+joff) - joff=joff+n - END DO - END DO - DO jb=1,ib - ip1=ip1+1 - ip=ip+1 - v(ip1)=vbk(ip) - END DO - END DO - - END IF - END IF - END IF - -END SUBROUTINE sqmibb2 diff --git a/millepede/mpqldec.f90 b/millepede/mpqldec.f90 deleted file mode 100644 index 139f6c9b72..0000000000 --- a/millepede/mpqldec.f90 +++ /dev/null @@ -1,647 +0,0 @@ -!> \file -!! QL decompostion. -!! -!! \author Claus Kleinwort, DESY, 2015 (Claus.Kleinwort@desy.de) -!! -!! \copyright -!! Copyright (c) 2015 Deutsches Elektronen-Synchroton, -!! Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n -!! 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. \n\n -!! 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. \n\n -!! You should have received a copy of the GNU Library General Public -!! License along with this program (see the file COPYING.LIB for more -!! details); if not, write to the Free Software Foundation, Inc., -!! 675 Mass Ave, Cambridge, MA 02139, USA. -!! -!! QL decomposition of constraints matrix by Householder transformations -!! for solution by elimination. -!! - -!> QL data. -MODULE mpqldec - USE mpdef - IMPLICIT NONE - - INTEGER(mpi) :: npar !< number of parameters - INTEGER(mpi) :: ncon !< number of constraints - REAL(mpd), DIMENSION(:), ALLOCATABLE :: matV !< unit normals (v_i) of Householder reflectors - REAL(mpd), DIMENSION(:), ALLOCATABLE :: matL !< lower diagonal matrix L - REAL(mpd), DIMENSION(:), ALLOCATABLE :: vecN !< normal vector - -END MODULE mpqldec - -!> Initialize QL decomposition. -!! -!! \param [in] n number of rows (parameters) -!! \param [in] m number of columns (constraints) -!! -SUBROUTINE qlini(n,m) - USE mpqldec - USE mpdalc - - IMPLICIT NONE - INTEGER(mpl) :: length - - INTEGER(mpi), INTENT(IN) :: n - INTEGER(mpi), INTENT(IN) :: m - - npar=n - ncon=m - ! allocate - length=npar*ncon - CALL mpalloc(matV,length,'QLDEC: V') - length=ncon*ncon - CALL mpalloc(matL,length,'QLDEC: L') - length=npar - CALL mpalloc(vecN,length,'QLDEC: v') -END SUBROUTINE qlini - -! 141217 C. Kleinwort, DESY-FH1 -!> QL decomposition. -!! -!! QL decomposition with Householder transformations. -!! Decompose N-By-M matrix A into orthogonal N-by-N matrix Q and a -!! N-by-M matrix containing zeros except for a lower triangular -!! M-by-M matrix L (at the bottom): -!! -!! | 0 | -!! A = Q * | | -!! | L | -!! -!! The decomposition is stored in a N-by-M matrix matV containing the unit -!! normal vectors v_i of the hyperplanes (Householder reflectors) defining Q. -!! The lower triangular matrix L is stored in the M-by-M matrix matL. -!! -!! \param [in] a Npar-by-Ncon matrix -!! -SUBROUTINE qldec(a) - USE mpqldec - USE mpdalc - - ! cost[dot ops] ~= Npar*Ncon*Ncon - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpl) :: ioff1 - INTEGER(mpl) :: ioff2 - INTEGER(mpl) :: ioff3 - INTEGER(mpi) :: k - INTEGER(mpi) :: kn - INTEGER(mpl) :: length - REAL(mpd) :: nrm - REAL(mpd) :: sp - - REAL(mpd), INTENT(IN) :: a(*) - - ! prepare - length=npar*ncon - matV=a(1:length) - matL=0.0_mpd - - ! Householder procedure - DO k=ncon,1,-1 - kn=npar+k-ncon - ! column offset - ioff1=(k-1)*npar - ! get column - vecN(1:kn)=matV(ioff1+1:ioff1+kn) - nrm = SQRT(dot_product(vecN(1:kn),vecN(1:kn))) - IF (nrm == 0.0_mpd) CYCLE - ! - IF (vecN(kn) >= 0.0_mpd) THEN - vecN(kn)=vecN(kn)+nrm - ELSE - vecN(kn)=vecN(kn)-nrm - END IF - ! create normal vector - nrm = SQRT(dot_product(vecN(1:kn),vecN(1:kn))) - vecN(1:kn)=vecN(1:kn)/nrm - ! transformation - ioff2=0 - DO i=1,k - sp=dot_product(vecN(1:kn),matV(ioff2+1:ioff2+kn)) - matV(ioff2+1:ioff2+kn)=matV(ioff2+1:ioff2+kn)-2.0_mpd*vecN(1:kn)*sp - ioff2=ioff2+npar - END DO - ! store column of L - ioff3=(k-1)*ncon - matL(ioff3+k:ioff3+ncon)=matV(ioff1+kn:ioff1+npar) - ! store normal vector - matV(ioff1+1:ioff1+kn)=vecN(1:kn) - matV(ioff1+kn+1:ioff1+npar)=0.0_mpd - END DO - -END SUBROUTINE qldec - -! 190312 C. Kleinwort, DESY-BELLE -!> QL decomposition (for disjoint block matrix). -!! -!! QL decomposition with Householder transformations. -!! Decompose N-By-M matrix A into orthogonal N-by-N matrix Q and a -!! N-by-M matrix containing zeros except for a lower triangular -!! M-by-M matrix L (at the bottom): -!! -!! | 0 | -!! A = Q * | | -!! | L | -!! -!! The decomposition is stored in a N-by-M matrix matV containing the unit -!! normal vectors v_i of the hyperplanes (Householder reflectors) defining Q. -!! The lower triangular matrix L is stored in the M-by-M matrix matL. -!! -!! \param [in] a block compressed Npar-by-Ncon matrix -!! \param [in] nb number of blocks -!! \param [in] b 3-by-Ncon+1 matrix (with block definition) -!! -SUBROUTINE qldecb(a,nb,b) - USE mpqldec - USE mpdalc - - ! cost[dot ops] ~= Npar*Ncon*Ncon - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ib - INTEGER(mpi) :: ifirst - INTEGER(mpi) :: ilast - INTEGER(mpl) :: ioff1 - INTEGER(mpl) :: ioff2 - INTEGER(mpl) :: ioff3 - INTEGER(mpi) :: k - INTEGER(mpi) :: k1 - INTEGER(mpi) :: kn - INTEGER(mpi) :: ncb - INTEGER(mpi) :: npb - INTEGER(mpl) :: length - REAL(mpd) :: nrm - REAL(mpd) :: sp - - REAL(mpd), INTENT(IN) :: a(*) - INTEGER(mpi), INTENT(IN) :: nb - INTEGER(mpi), INTENT(IN) :: b(3,*) - - ! prepare - length=npar*ncon - matV=0.0_mpd - matL=0.0_mpd - ! expand a into matV - ioff1=0 - ioff2=0 - DO ib=1,nb - ncb=b(1,ib+1)-b(1,ib) ! number of constraints in block - npb=b(3,ib)+1-b(2,ib) ! number of parameters in block - ifirst=b(2,ib) - ilast=b(3,ib) - DO i=1,ncb - matV(ioff1+ifirst:ioff1+ilast)=a(ioff2+1:ioff2+npb) - ioff1=ioff1+npar - ioff2=ioff2+npb - END DO - END DO - - ib=nb ! start with last block - k1=b(1,ib) ! first constraint in block - ! Householder procedure - DO k=ncon,1,-1 - kn=npar+k-ncon - ! different block? - IF (k < k1) THEN - ib=ib-1 - k1=b(1,ib) - END IF - ! index if first non-zero element - ifirst=b(2,ib) - IF (ifirst > kn) CYCLE - ! index of last element - ilast=min(b(3,ib),kn) - ! column offsets - ioff1=(k-1)*npar - ioff2=(k1-1)*npar - ! get column - vecN(kn)=0.0_mpd - vecN(ifirst:ilast)=matV(ioff1+ifirst:ioff1+ilast) - nrm = SQRT(dot_product(vecN(ifirst:ilast),vecN(ifirst:ilast))) - IF (nrm == 0.0_mpd) CYCLE - ! - IF (vecN(kn) >= 0.0_mpd) THEN - vecN(kn)=vecN(kn)+nrm - ELSE - vecN(kn)=vecN(kn)-nrm - END IF - - IF (ilast < kn) THEN - ! create normal vector - nrm = SQRT(dot_product(vecN(ifirst:ilast),vecN(ifirst:ilast))+vecN(kn)*vecN(kn)) - vecN(ifirst:ilast)=vecN(ifirst:ilast)/nrm - vecN(kn)=vecN(kn)/nrm - ! transformation - DO i=k1,k - sp=dot_product(vecN(ifirst:ilast),matV(ioff2+ifirst:ioff2+ilast)) - matV(ioff2+ifirst:ioff2+ilast)=matV(ioff2+ifirst:ioff2+ilast)-2.0_mpd*vecN(ifirst:ilast)*sp - matV(ioff2+kn)=-2.0_mpd*vecN(kn)*sp - ioff2=ioff2+npar - END DO - ELSE - ! create normal vector - nrm = SQRT(dot_product(vecN(ifirst:ilast),vecN(ifirst:ilast))) - vecN(ifirst:ilast)=vecN(ifirst:ilast)/nrm - ! transformation - DO i=k1,k - sp=dot_product(vecN(ifirst:ilast),matV(ioff2+ifirst:ioff2+ilast)) - matV(ioff2+ifirst:ioff2+ilast)=matV(ioff2+ifirst:ioff2+ilast)-2.0_mpd*vecN(ifirst:ilast)*sp - ioff2=ioff2+npar - END DO - END IF - - ! store column of L - ioff3=(k-1)*ncon - matL(ioff3+k:ioff3+ncon)=matV(ioff1+kn:ioff1+npar) - ! store normal vector - matV(ioff1+1:ioff1+npar)=0.0_mpd - matV(ioff1+ifirst:ioff1+ilast)=vecN(ifirst:ilast) - matV(ioff1+kn)=vecN(kn) - END DO - -END SUBROUTINE qldecb - - -!> Multiply left by Q(t). -!! -!! Multiply left by Q(t) from QL decomposition. -!! -!! \param [in,out] x Npar-by-M matrix, overwritten with Q*X (t=false) or Q^t*X (t=true) -!! \param [in] m number of columns -!! \param [in] t use transposed of Q -!! -SUBROUTINE qlmlq(x,m,t) - USE mpqldec - - ! cost[dot ops] ~= N*M*Nhr - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpl) :: ioff1 - INTEGER(mpl) :: ioff2 - INTEGER(mpi) :: j - INTEGER(mpi) :: k - INTEGER(mpi) :: kn - REAL(mpd) :: sp - - REAL(mpd), INTENT(IN OUT) :: x(*) - INTEGER(mpi), INTENT(IN) :: m - LOGICAL, INTENT(IN) :: t - - DO j=1,ncon - k=j - IF (t) k=ncon+1-j - kn=npar+k-ncon - ! column offset - ioff1=(k-1)*npar - ! transformation - ioff2=0 - DO i=1,m - sp=dot_product(matV(ioff1+1:ioff1+kn),x(ioff2+1:ioff2+kn)) - x(ioff2+1:ioff2+kn)=x(ioff2+1:ioff2+kn)-2.0_mpd*matV(ioff1+1:ioff1+kn)*sp - ioff2=ioff2+npar - END DO - END DO - -END SUBROUTINE qlmlq - - -!> Multiply right by Q(t). -!! -!! Multiply right by Q(t) from QL decomposition. -!! -!! \param [in,out] x M-by-Npar matrix, overwritten with X*Q (t=false) or X*Q^t (t=true) -!! \param [in] m number of rows -!! \param [in] t use transposed of Q -!! -SUBROUTINE qlmrq(x,m,t) - USE mpqldec - - ! cost[dot ops] ~= N*M*Nhr - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpl) :: ioff1 - INTEGER(mpl) :: iend - INTEGER(mpi) :: j - INTEGER(mpi) :: k - INTEGER(mpi) :: kn - REAL(mpd) :: sp - - REAL(mpd), INTENT(IN OUT) :: x(*) - INTEGER(mpi), INTENT(IN) :: m - LOGICAL, INTENT(IN) :: t - - DO j=1,ncon - k=j - IF (.not.t) k=ncon+1-j - kn=npar+k-ncon - ! column offset - ioff1=(k-1)*npar - ! transformation - iend=m*kn - DO i=1,npar - sp=dot_product(matV(ioff1+1:ioff1+kn),x(i:iend:m)) - x(i:iend:m)=x(i:iend:m)-2.0_mpd*matV(ioff1+1:ioff1+kn)*sp - END DO - END DO - -END SUBROUTINE qlmrq - - -!> Similarity transformation by Q(t). -!! -!! Similarity transformation by Q from QL decomposition. -!! -!! \param [in,out] x Npar-by-Npar matrix, overwritten with Q*X*Q^t (t=false) or Q^t*X*Q (t=true) -!! \param [in] t use transposed of Q -!! -SUBROUTINE qlsmq(x,t) - USE mpqldec - - ! cost[dot ops] ~= N*N*Nhr - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpl) :: ioff1 - INTEGER(mpl) :: ioff2 - INTEGER(mpl) :: iend - INTEGER(mpi) :: j - INTEGER(mpi) :: k - INTEGER(mpi) :: kn - REAL(mpd) :: sp - - REAL(mpd), INTENT(IN OUT) :: x(*) - LOGICAL, INTENT(IN) :: t - - DO j=1,ncon - k=j - IF (t) k=ncon+1-j - kn=npar+k-ncon - ! column offset - ioff1=(k-1)*npar - ! transformation - iend=npar*kn - DO i=1,npar - sp=dot_product(matV(ioff1+1:ioff1+kn),x(i:iend:npar)) - x(i:iend:npar)=x(i:iend:npar)-2.0_mpd*matV(ioff1+1:ioff1+kn)*sp - END DO - ioff2=0 - DO i=1,npar - sp=dot_product(matV(ioff1+1:ioff1+kn),x(ioff2+1:ioff2+kn)) - x(ioff2+1:ioff2+kn)=x(ioff2+1:ioff2+kn)-2.0_mpd*matV(ioff1+1:ioff1+kn)*sp - ioff2=ioff2+npar - END DO - END DO - -END SUBROUTINE qlsmq - - -!> Similarity transformation by Q(t). -!! -!! Similarity transformation for symmetric matrix by Q from QL decomposition. -!! -!! \param [in] aprod external procedure to calculate A*v -!! \param [in,out] A symmetric Npar-by-Npar matrix A in symmetric storage mode -!! (V(1) = V11, V(2) = V12, V(3) = V22, V(4) = V13, ...), -!! overwritten with Q*A*Q^t (t=false) or Q^t*A*Q (t=true) -!! \param [in] t use transposed of Q -!! -SUBROUTINE qlssq(aprod,A,t) - USE mpqldec - USE mpdalc - - ! cost[dot ops] ~= N*N*Nhr - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpl) :: ioff1 - INTEGER(mpl) :: ioff2 - INTEGER(mpi) :: j - INTEGER(mpi) :: k - INTEGER(mpi) :: kn - INTEGER(mpi) :: l - INTEGER(mpl) :: length - REAL(mpd) :: vtAv - REAL(mpd), DIMENSION(:), ALLOCATABLE :: Av - - REAL(mpd), INTENT(IN OUT) :: A(*) - LOGICAL, INTENT(IN) :: t - - INTERFACE - SUBROUTINE aprod(n,x,y) ! y=A*x - USE mpdef - INTEGER(mpi), INTENT(in) :: n - REAL(mpd), INTENT(IN) :: x(n) - REAL(mpd), INTENT(OUT) :: y(n) - END SUBROUTINE aprod - END INTERFACE - - length=npar - CALL mpalloc(Av,length,'qlssq: A*v') - - DO j=1,ncon - k=j - IF (t) k=ncon+1-j - kn=npar+k-ncon - ! column offset - ioff1=(k-1)*npar - ! A*v - CALL aprod(npar,matV(ioff1+1:ioff1+npar),Av(1:npar)) - ! transformation - ! diagonal block - ! v^t*A*v - vtAv=dot_product(matV(ioff1+1:ioff1+kn),Av(1:kn)) - ! update - ioff2=0 - DO i=1,kn - ! correct with 2*(2v*vtAv*v^t - Av*v^t - (Av*v^t)^t) - DO l=1,i - ioff2=ioff2+1 - A(ioff2)=A(ioff2)+2.0_mpd*((2.0_mpd*matV(ioff1+i)*vtAv-Av(i))*matV(ioff1+l)-Av(l)*matV(ioff1+i)) - END DO - END DO - ! off diagonal block - DO i=kn+1,npar - ! correct with -2Av*v^t - A(ioff2+1:ioff2+kn)=A(ioff2+1:ioff2+kn)-2.0_mpd*matV(ioff1+1:ioff1+kn)*Av(i) - ioff2=ioff2+i - END DO - END DO - - CALL mpdealloc(Av) - -END SUBROUTINE qlssq - - -!> Partial similarity transformation by Q(t). -!! -!! Partial similarity transformation for symmetric matrix by Q from QL decomposition. -!! Calculate corrections to band part of matrix. -!! -!! \param [in] aprod external procedure to calculate A*v -!! \param [in,out] B band part of symmetric Npar-by-Npar matrix A in symmetric storage mode, -!! overwritten with band part of Q^t*A*Q (t=false) or Q^t*A*Q (t=true) -!! \param [in] m band width (including diagonal) -!! \param [in] t use transposed of Q -!! -SUBROUTINE qlpssq(aprod,B,m,t) - USE mpqldec - USE mpdalc - - ! cost[dot ops] ~= N*N*Nhr - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpl) :: ioff1 - INTEGER(mpl) :: ioff2 - INTEGER(mpi) :: j - INTEGER(mpi) :: j2 - INTEGER(mpi) :: k - INTEGER(mpi) :: k2 - INTEGER(mpi) :: kn - INTEGER(mpi) :: l - INTEGER(mpl) :: length - INTEGER(mpi) :: mbnd - REAL(mpd) :: vtAv - REAL(mpd) :: vtAvp - REAL(mpd) :: vtvp - REAL(mpd), DIMENSION(:), ALLOCATABLE :: Av ! A*v - - REAL(mpd), INTENT(IN OUT) :: B(*) - INTEGER(mpi), INTENT(IN) :: m - LOGICAL, INTENT(IN) :: t - - INTERFACE - SUBROUTINE aprod(n,x,y) ! y=A*x - USE mpdef - INTEGER(mpi), INTENT(in) :: n - REAL(mpd), INTENT(IN) :: x(n) - REAL(mpd), INTENT(OUT) :: y(n) - END SUBROUTINE aprod - END INTERFACE - - length=npar - length=npar*ncon - CALL mpalloc(Av,length,'qlpssq: Av') - - mbnd=max(0,m-1) ! band width without diagonal - ! A*V - ioff1=0 - DO i=1,ncon - CALL aprod(npar,matV(ioff1+1:ioff1+npar),Av(ioff1+1:ioff1+npar)) - ioff1=ioff1+npar - END DO - - DO j=1,ncon - k=j - IF (t) k=ncon+1-j - kn=npar+k-ncon - ! column offset - ioff1=(k-1)*npar - ! transformation (diagonal block) - ! diagonal block - ! v^t*A*v - vtAv=dot_product(matV(ioff1+1:ioff1+kn),Av(ioff1+1:ioff1+kn)) - ! update - ioff2=0 - DO i=1,kn - ! correct with 2*(2v*vtAv*v^t - Av*v^t - (Av*v^t)^t) - DO l=max(1,i-mbnd),i - ioff2=ioff2+1 - B(ioff2)=B(ioff2)+2.0_mpd*((2.0_mpd*matV(ioff1+i)*vtAv-Av(ioff1+i))*matV(ioff1+l)-Av(ioff1+l)*matV(ioff1+i)) - END DO - END DO - ! off diagonal block - DO i=kn+1,npar - ! correct with -2Av*v^t - DO l=max(1,i-mbnd),i - ioff2=ioff2+1 - B(ioff2)=B(ioff2)-2.0_mpd*Av(ioff1+i)*matV(ioff1+l) - END DO - END DO - ! correct A*v for the remainung v - DO j2=j+1,ncon - k2=j2 - IF (t) k2=ncon+1-j2 - ioff2=(k2-1)*npar - vtvp=dot_product(matV(ioff1+1:ioff1+npar),matV(ioff2+1:ioff2+npar)) ! v^t*v' - vtAvp=dot_product(matV(ioff1+1:ioff1+npar),Av(ioff2+1:ioff2+npar)) ! v^t*(A*v') - DO i=1,kn - Av(ioff2+i)=Av(ioff2+i)+2.0_mpd*((2.0_mpd*matV(ioff1+i)*vtAv-Av(ioff1+i))*vtvp-matV(ioff1+i)*vtAvp) - END DO - DO i=kn+1,npar - Av(ioff2+i)=Av(ioff2+i)-2.0_mpd*Av(ioff1+i)*vtvp - END DO - END DO - - END DO - - CALL mpdealloc(Av) - -END SUBROUTINE qlpssq - - -!> Get eigenvalues. -!! -!! Get smallest and largest |eigenvalue| of L. -!! -!! \param [out] emin eigenvalue with smallest absolute value -!! \param [out] emax eigenvalue with largest absolute value -!! -SUBROUTINE qlgete(emin,emax) - USE mpqldec - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpl) :: idiag - - REAL(mpd), INTENT(OUT) :: emin - REAL(mpd), INTENT(OUT) :: emax - - idiag=1 - emax=matL(1) - emin=emax - DO i=2,ncon - idiag=idiag+ncon+1 - IF (ABS(emax) < ABS(matL(idiag))) emax=matL(idiag) - IF (ABS(emin) > ABS(matL(idiag))) emin=matL(idiag) - END DO - -END SUBROUTINE qlgete - - -!> Backward substitution. -!! -!! Get y from L^t*y=d. -!! -!! \param [in] d Ncon vector, resdiduals -!! \param [out] y Ncon vector, solution -!! -SUBROUTINE qlbsub(d,y) - USE mpqldec - - IMPLICIT NONE - INTEGER(mpl) :: idiag - INTEGER(mpi) :: k - - REAL(mpd), INTENT(IN) :: d(ncon) - REAL(mpd), INTENT(OUT) :: y(ncon) - - ! solve L*y=d by forward substitution - idiag=ncon*ncon - DO k=ncon,1,-1 - y(k)=(d(k)-dot_product(matL(idiag+1:idiag+ncon-k),y(k+1:ncon)))/matL(idiag) - idiag=idiag-ncon-1 - END DO - -END SUBROUTINE qlbsub diff --git a/millepede/mptest1.f90 b/millepede/mptest1.f90 deleted file mode 100644 index 439c1526fa..0000000000 --- a/millepede/mptest1.f90 +++ /dev/null @@ -1,357 +0,0 @@ - -! Code converted using TO_F90 by Alan Miller -! Date: 2012-03-16 Time: 11:08:48 - -!> \file -!! MC for simple 100 plane chamber. -!! -!! \author Volker Blobel, University Hamburg, 2005-2009 (initial Fortran77 version) -!! \author Claus Kleinwort, DESY (maintenance and developement) -!! -!! \copyright -!! Copyright (c) 2009 - 2015 Deutsches Elektronen-Synchroton, -!! Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n -!! 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. \n\n -!! 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. \n\n -!! You should have received a copy of the GNU Library General Public -!! License along with this program (see the file COPYING.LIB for more -!! details); if not, write to the Free Software Foundation, Inc., -!! 675 Mass Ave, Cambridge, MA 02139, USA. -!! -!! No B-field, straight tracks. Selected with command line option '-t'. -!! -!! Global parameters: -!! - Position offsets in measurement direction (alignment). -!! - Relative drift velocity corrections (calibration). - - -!> Parameters and data. -MODULE mptest1 - USE mpdef - - IMPLICIT NONE - SAVE - - INTEGER(mpi), PARAMETER :: nplan=100 - - ! define detector geometry - REAL(mps), PARAMETER :: detx= 10.0 !< x-value of first plane - REAL(mps), PARAMETER :: disx= 10.0 !< distance between planes - REAL(mps), PARAMETER :: thck= 2.0 !< thickness of plane - REAL(mps), PARAMETER :: heit=100.0 !< height of detector plane - REAL(mps), PARAMETER :: effp=0.90 !< plane efficiency - REAL(mps), PARAMETER :: sgmp=0.0150 !< measurement sigma - - ! misalignment - REAL(mps), DIMENSION(nplan) :: del !< shift (position deviation) (alignment parameter) - REAL(mps), DIMENSION(nplan) :: dvd !< rel. drift velocity deviation (calibration parameter) - ! track parameter - REAL(mps) :: ynull !< track position at vertex - REAL(mps) :: slope !< track slope - - INTEGER(mpi) :: nhits !< number of hits - INTEGER(mpi), DIMENSION(nplan) :: ihits !< plane numbers (planes with hits) - REAL(mps), DIMENSION(nplan) :: eff !< plane efficiency - REAL(mps), DIMENSION(nplan) :: sgm !< measurement sigma (plane) - REAL(mps), DIMENSION(nplan) :: ydrft !< signed drift length - REAL(mps), DIMENSION(nplan) :: xhits !< position perp. to plane (hit) - REAL(mps), DIMENSION(nplan) :: yhits !< measured position in plane (hit) - REAL(mps), DIMENSION(nplan) :: sigma !< measurement sigma (hit) - -END MODULE mptest1 - -!> Generate test files. -!! -!! Create text and binary files. -!! -!! unit 8: textfile mp2str.txt = steering file -!! unit 9: textfile mp2con.txt = constraint file -!! unit 51: binary file mp2test.bin, written using CALL MILLE(.) -!! existing file are removed - -SUBROUTINE mptest - USE mptest1 - - IMPLICIT NONE - REAL(mps) :: dbar - REAL(mps) :: det - REAL(mps) :: displ - REAL(mps) :: drift - REAL(mps) :: eps - REAL(mps) :: eta - REAL(mps) :: gran - REAL(mps) :: one - REAL(mps) :: ww - REAL(mps) :: x - REAL(mps) :: xbar - INTEGER(mpi) :: i - INTEGER(mpi) :: icount - INTEGER(mpi) :: ios - INTEGER(mpi) :: ip - INTEGER(mpi) :: ipl - INTEGER(mpi) :: labelt - INTEGER(mpi) :: luns - INTEGER(mpi) :: lunt - INTEGER(mpi) :: ncount - INTEGER(mpi) :: nrecds - INTEGER(mpi) :: nthits - - REAL(mpd) :: s1 - REAL(mpd) :: s2 - REAL(mpd) :: sw - REAL(mpd) :: sv - REAL(mpd) :: sum1 - REAL(mpd) :: sum2 - REAL(mps) :: derlc(2) - REAL(mps) :: dergl(2) - INTEGER(mpi) :: label(2) - LOGICAL :: ex1 - LOGICAL :: ex2 - LOGICAL :: ex3 - ! ... - !CC CALL RNTIME - INQUIRE(FILE='mp2str.txt',IOSTAT=ios,EXIST=ex1) ! keep, if existing - INQUIRE(FILE='mp2con.txt',IOSTAT=ios,EXIST=ex2) ! keep, if existing - - INQUIRE(FILE='mp2tst.bin',IOSTAT=ios,EXIST=ex3) ! remove, if existing - - WRITE(*,*) ' ' - WRITE(*,*) 'Generating test data for mp II...' - WRITE(*,*) ' ' - ! file management - IF(ex3) CALL system('rm mp2tst.bin') ! remove old file - - IF(.NOT.ex1) OPEN(UNIT=7,ACCESS='SEQUENTIAL',FORM='FORMATTED', & - FILE='mp2str.txt') - IF(.NOT.ex2) OPEN(UNIT=9,ACCESS='SEQUENTIAL',FORM='FORMATTED', & - FILE='mp2con.txt') - OPEN(UNIT=51,ACCESS='SEQUENTIAL',FORM='UNFORMATTED', FILE='mp2tst.bin') - - DO i=1,nplan - eff(i)=effp ! plane efficiency - sgm(i)=sgmp ! measurement sigma - del(i)=0.0 ! true shift is zero - END DO - - ipl=7 ! modify one plane (7) - eff(ipl)=0.1 ! low efficiency - sgm(ipl)=0.0400 ! bad resolution - - ! misalign detector planes ----------------------------------------- - - displ=0.1 ! displacement 1 mm * N(0,1) - drift=0.02 ! Vdrift deviation 2 % * N(0,1) - DO i=1,nplan - del(i)=displ*gran() ! shift - dvd(i)=drift*gran() ! rel. drift velocitu deviation - END DO - del(10)=0.0 ! no shift - del(90)=0.0 ! no shift - - ! write text files ------------------------------------------------- - - IF(.NOT.ex1) THEN - luns=7 ! steerfile - WRITE(luns,101) '* Default test steering file' - WRITE(luns,101) 'fortranfiles ! following bin files are fortran' - WRITE(luns,101) 'mp2con.txt ! constraints text file ' - WRITE(luns,101) 'mp2tst.bin ! binary data file' - WRITE(luns,101) 'Cfiles ! following bin files are Cfiles' - ! WRITE(LUNS,101) '*outlierrejection 100.0 ! reject if Chi^2/Ndf >' - ! WRITE(LUNS,101) '*outliersuppression 3 ! 3 local_fit iterations' - - WRITE(luns,101) '*hugecut 50.0 !cut factor in iteration 0' - WRITE(luns,101) '*chisqcut 1.0 1.0 ! cut factor in iterations 1 and 2' - WRITE(luns,101) '*entries 10 ! lower limit on number of entries/parameter' - WRITE(luns,101) & - '*pairentries 10 ! lower limit on number of parameter pairs', & - ' ! (not yet!)' - WRITE(luns,101) '*printrecord 1 2 ! debug printout for records' - WRITE(luns,101) & - '*printrecord -1 -1 ! debug printout for bad data records' - WRITE(luns,101) & - '*outlierdownweighting 2 ! number of internal iterations (> 1)' - WRITE(luns,101) '*dwfractioncut 0.2 ! 0 < value < 0.5' - WRITE(luns,101) '*presigma 0.01 ! default value for presigma' - WRITE(luns,101) '*regularisation 1.0 ! regularisation factor' - WRITE(luns,101) '*regularisation 1.0 0.01 ! regularisation factor, pre-sigma' - - WRITE(luns,101) ' ' - WRITE(luns,101) '*bandwidth 0 ! width of precond. band matrix' - WRITE(luns,101) 'method diagonalization 3 0.001 ! diagonalization ' - WRITE(luns,101) 'method fullMINRES 3 0.01 ! minimal residual ' - WRITE(luns,101) 'method sparseMINRES 3 0.01 ! minimal residual ' - WRITE(luns,101) '*mrestol 1.0D-8 ! epsilon for MINRES' - WRITE(luns,101) 'method inversion 3 0.001 ! Gauss matrix inversion' - WRITE(luns,101) '* last method is applied' - WRITE(luns,101) '*matiter 3 ! recalculate matrix in iterations' - WRITE(luns,101) ' ' - WRITE(luns,101) 'end ! optional for end-of-data' - ENDIF - - lunt=9 ! constraint file - one=1.0 ! shift constraint - IF(.NOT.ex2) WRITE(lunt,*) 'Constraint 0.0' - DO i=1,nplan - labelt=10+i*2 - x=detx+REAL(i-1,mps)*disx+0.5*thck - IF(.NOT.ex2) WRITE(lunt,103) labelt,one - END DO - - sw=0.0_mpd ! tilt constraint - sv=0.0_mpd - s1=0.0_mpd - s2=0.0_mpd - IF(.NOT.ex2) WRITE(lunt,*) 'Constraint 0.0' ! write - dbar=0.5*REAL(nplan-1,mps)*disx - xbar=detx+0.5*REAL(nplan-1,mps)*disx! +0.5*THCK - DO i=1,nplan - labelt=10+i*2 - x=detx+REAL(i-1,mps)*disx !+0.5*THCK - ww=(x-xbar)/dbar - IF(.NOT.ex2) WRITE(lunt,103) labelt,ww ! write - s1=s1+del(i) - s2=s2+ww*del(i) - sw=sw+ww - sv=sv+ww*ww - END DO - - - det=REAL(REAL(nplan,mpd)*sv-sw*sw,mps) - eps=REAL(sv*s1-sw*s2,mps)/det - eta=REAL(REAL(nplan,mpd)*s2-sw*s1,mps)/det - DO i=1,nplan - x=detx+REAL(i-1,mps)*disx - ww=(x-xbar)/dbar - del(i)=del(i)-eps-eta*ww ! correct displacement ... - END DO ! ... for constraints - - sum1=0.0 - sum2=0.0 - DO i=1,nplan - sum1=sum1+del(i) - x=detx+REAL(i-1,mps)*disx !+0.5*THCK - ww=(x-xbar)/dbar - sum2=sum2+del(i)*ww - END DO - ! WRITE(*,*) ' Check for constraints ',SUM1,SUM2 - - ! record loop ------------------------------------------------------ - - ncount=10000 - nthits=0 - nrecds=0 - - DO icount=1,ncount - ip=0 - IF(icount == 8759) ip=1 - ! IF(ICOUNT.EQ.6309) IP=1 - ! IF(ICOUNT.EQ.7468) IP=1 - CALL genlin(ip) ! generate hits - - DO i=1,nhits - derlc(1)=1.0 - derlc(2)=xhits(i) - dergl(1)=1.0 - dergl(2)=ydrft(i) - label(1)=10+ihits(i)*2 - label(2)=500 + ihits(i) - CALL mille(2,derlc,2,dergl,label,yhits(i),sigma(i)) - nthits=nthits+1 ! count hits - END DO - CALL endle - nrecds=nrecds+1 ! count records - END DO - - ! ------------------------------------------------------------------ - IF(.NOT.ex1) THEN - REWIND (7) - CLOSE (7) - END IF - IF(.NOT.ex2) THEN - REWIND (9) - CLOSE (9) - END IF - REWIND (51) - CLOSE (51) - - ! WRITE(*,*) ' ' - ! WRITE(*,*) 'Shifts and drift velocity deviations:' - ! DO I=1,NPLAN - ! WRITE(*,102) I,DEL(I),DVD(I) - ! END DO - - - WRITE(*,*) ' ' - WRITE(*,*) ' ' - WRITE(*,*) ncount,' tracks generated with ',nthits,' hits.' - WRITE(*,*) nrecds,' records written.' - WRITE(*,*) ' ' -101 FORMAT(a) - ! 102 FORMAT(I6,2F10.5) -103 FORMAT(i8,f10.5) -END SUBROUTINE mptest ! gener - -!> Generate line and measurements. -!! -!! \param [in] ip print flag - -SUBROUTINE genlin(ip) - USE mptest1 - - IMPLICIT NONE - REAL(mps) :: gr - REAL(mps) :: gran - REAL(mps) :: uran - REAL(mps) :: x - REAL(mps) :: ybias - REAL(mps) :: ydvds - REAL(mps) :: ylin - REAL(mps) :: ymeas - REAL(mps) :: ywire - INTEGER(mpi) :: i - INTEGER(mpi) :: nwire - - INTEGER(mpi), INTENT(IN) :: ip - - ! ... - ynull=0.5*heit+0.1*heit*(uran()-0.5) ! uniform vertex - slope=(uran()-0.5)*heit/(REAL(nplan-1,mps)*disx) - IF(ip /= 0) THEN - WRITE(*,*) ' ' - ! WRITE(*,*) 'YNULL=',YNULL,' SLOPE=',SLOPE - END IF - nhits=0 - DO i=1,nplan - x=detx+REAL(i-1,mps)*disx ! +0.5*THCK - IF(uran() < eff(i)) THEN - ylin =ynull+slope*x ! true y value - ybias =ylin-del(i) ! biased value - nwire=INT(1.0+ybias/4.0,mpi) ! wire number - IF(nwire <= 0.OR.nwire > 25) EXIT ! check wire number - nhits=nhits+1 ! track hits the plane - xhits(nhits)=x - ihits(nhits)=i - gr=gran() - ymeas=sgm(i)*gr - ydvds=0.0 - yhits(nhits)=ybias+ymeas+ydvds ! measured - ywire=REAL(nwire,mps)*4.0-2.0 - ydrft(nhits)=ybias-ywire ! signed drift length - ydvds=ydrft(nhits)*dvd(i) - yhits(nhits)=ybias+ymeas-ydvds ! measured - sigma(nhits)=sgm(i) - IF(ip /= 0) THEN - ! WRITE(*,101) NHITS,I,X,YLIN,YBIAS,YMEAS, - ! + SGM(I),YHITS(NHITS),GR,DEL(I) - END IF - END IF - END DO -! 101 FORMAT(2I3,F5.0,7F8.4) -END SUBROUTINE genlin diff --git a/millepede/mptest2.f90 b/millepede/mptest2.f90 deleted file mode 100644 index e4c5ced475..0000000000 --- a/millepede/mptest2.f90 +++ /dev/null @@ -1,507 +0,0 @@ - -! Code converted using TO_F90 by Alan Miller -! Date: 2012-03-16 Time: 11:08:55 - -!> \file -!! MC for simple 10 layer silicon strip tracker. -!! -!! \author Claus Kleinwort, DESY, 2009 -!! -!! \copyright -!! Copyright (c) 2009 - 2015 Deutsches Elektronen-Synchroton, -!! Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n -!! 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. \n\n -!! 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. \n\n -!! You should have received a copy of the GNU Library General Public -!! License along with this program (see the file COPYING.LIB for more -!! details); if not, write to the Free Software Foundation, Inc., -!! 675 Mass Ave, Cambridge, MA 02139, USA. -!! -!! No B-field, straight tracks. Selected with command line option '-t=track-model' -!! The \a track-models differ in the implementation of multiple scattering (errors): -!! - \c SL0: Ignore multiple scattering. Fit 4 track parameters. -!! - \c SLE: Ignore correlations due to multiple scattering, use only diagonal of -!! m.s. covariance matrix. Fit 4 track parameters. -!! - \c BP: Intoduce explicit scattering angles at each scatterer. -!! Fit 4+2*(\ref mptest2::nmlyr "nmlyr"-2) parameters. -!! Matrix of corresponding linear equation system is full and solution -!! is obtained by inversion (time ~ parameters^3). -!! - \c BRLF: Use (fine) broken lines (see \ref ref_sec). Multiple scattering kinks -!! are described by triplets of offsets at scatterers as track parameters. -!! Fit 4+2*(\ref mptest2::nmlyr "nmlyr"-2) parameters. Matrix of corresponding -!! linear equation system has band structure and solution -!! is obtained by root-free Cholesky decomposition (time ~ parameters). -!! - \c BRLC: Use (coarse) broken lines. Similar to \c BRLF, but with stereo layers -!! combined into single layer/scatterer. Fit 4+2*(\ref mptest2::nlyr "nlyr"-2) parameters. -!! -!! MC for simple silicon strip tracker: -!! - 10 silicon detector layers -!! - 50 modules per layer (1*2cm) -!! - 10 cm spacing, no B-field -!! - layers 1,4,7,10 have additional +/-5deg stereo modules -!! - intrinsic resolution 20mu, 2% X0 per strip module -!! - uniform track offsets/slopes -!! - momentum: log10(p) 10..100 GeV uniform -!! -!! Global parameters: -!! - Position offsets (2D) in measurement plane per module (alignment). -!! - -!> Parameters and data. -MODULE mptest2 - USE mpdef - - IMPLICIT NONE - SAVE - - INTEGER(mpi), PARAMETER :: nlyr=10 !< number of detector layers - INTEGER(mpi), PARAMETER :: nmlyr=14 !< number of measurement layers - INTEGER(mpi), PARAMETER :: nmx=10 !< number of modules in x direction - INTEGER(mpi), PARAMETER :: nmy=5 !< number of modules in y direction - INTEGER(mpi), PARAMETER :: ntot=nlyr*nmx*nmy !< total number of modules - ! define detector geometry - REAL(mps), PARAMETER :: dets= 10.0 !< arclength of first plane - REAL(mps), PARAMETER :: diss= 10.0 !< distance between planes - REAL(mps), PARAMETER :: thck= 0.02 !< thickness of plane (X0) - REAL(mps), PARAMETER :: offs= 0.5 !< offset of stereo modules - REAL(mps), PARAMETER :: stereo=0.08727 !< stereo angle - REAL(mps), PARAMETER :: sizel= 20.0 !< size of layers - REAL(mps), PARAMETER :: sigl =0.002 ! Generate test files. -!! -!! Create text and binary files. -!! -!! unit 8: textfile mp2str.txt = steering file -!! unit 9: textfile mp2con.txt = constraint file -!! unit 51: binary file mp2test.bin, written using CALL MILLE(.) -!! existing file are removed -!! -!! \param [in] imodel track model -!! -!! 0: 'straight line', ignoring multiple scattering -!! 1: 'straight line', using diagonal of m.s. error matrix -!! 2: 'break points' -!! 3: 'broken lines', fine -!! 4: 'broken lines', coarse (stereo layers combined) -!! - -SUBROUTINE mptst2(imodel) ! generate test files - USE mptest2 - IMPLICIT NONE - REAL(mps) :: cmbbrl - REAL(mps) :: dispxm - REAL(mps) :: dispym - REAL(mps) :: dn - REAL(mps) :: dp - REAL(mps) :: gran - REAL(mps) :: one - REAL(mps) :: p - REAL(mps) :: s - REAL(mps) :: sgn - REAL(mps) :: sbrl - REAL(mps) :: sold - REAL(mps) :: uran - REAL(mps) :: wbrl - INTEGER(mpi) :: i - INTEGER(mpi) :: ibrl - INTEGER(mpi) :: icount - INTEGER(mpi) :: im - INTEGER(mpi) :: ios - INTEGER(mpi) :: ip - INTEGER(mpi) :: j - INTEGER(mpi) :: k - INTEGER(mpi) :: l - INTEGER(mpi) :: labelt - INTEGER(mpi) :: layer - INTEGER(mpi) :: lb - INTEGER(mpi) :: lbrl - INTEGER(mpi) :: luns - INTEGER(mpi) :: lunt - INTEGER(mpi) :: lyr - INTEGER(mpi) :: nalc - INTEGER(mpi) :: nbrl - INTEGER(mpi) :: ncount - INTEGER(mpi) :: ncx - INTEGER(mpi) :: nmxy - INTEGER(mpi) :: nrecds - INTEGER(mpi) :: nthits - - INTEGER(mpi), INTENT(IN) :: imodel - - REAL(mps) :: derlc(nmlyr*2+3) - REAL(mps) :: dergl(nmlyr*2+3) - INTEGER(mpi) :: label(2) - LOGICAL :: ex1 - LOGICAL :: ex2 - LOGICAL :: ex3 - ! for broken lines: 1=fine, 2=coarse - DIMENSION nbrl(2),lbrl(nmlyr,2),sbrl(nmlyr,2),wbrl(nmlyr,2), cmbbrl(2) - DATA cmbbrl / 0.0, 1.0 / ! cut for combining layers - ! ... - !CC CALL RNTIME - INQUIRE(FILE='mp2str.txt',IOSTAT=ios,EXIST=ex1) ! keep, if existing - INQUIRE(FILE='mp2con.txt',IOSTAT=ios,EXIST=ex2) ! keep, if existing - - INQUIRE(FILE='mp2tst.bin',IOSTAT=ios,EXIST=ex3) ! remove, if existing - - WRITE(*,*) ' ' - WRITE(*,*) 'Generating test data for mp II...' - WRITE(*,*) ' ' - ! file management - IF(ex3) CALL system('rm mp2tst.bin') ! remove old file - - IF(.NOT.ex1) OPEN(UNIT=7,ACCESS='SEQUENTIAL',FORM='FORMATTED', & - FILE='mp2str.txt') - IF(.NOT.ex2) OPEN(UNIT=9,ACCESS='SEQUENTIAL',FORM='FORMATTED', & - FILE='mp2con.txt') - OPEN(UNIT=51,ACCESS='SEQUENTIAL',FORM='UNFORMATTED', FILE='mp2tst.bin') - - s=dets - i=0 - sgn=1.0 - DO layer=1,10 - i=i+1 - islyr(i)=layer ! layer - sarc(i)=s ! arclength - ssig(i)=sigl ! resolution - spro(1,i)=1.0 ! module measures 'X' - spro(2,i)=0.0 - IF (MOD(layer,3) == 1) THEN - i=i+1 - islyr(i)=layer ! layer - sarc(i)=s+offs ! arclength stereo module - ssig(i)=sigl ! resolution - spro(1,i)=SQRT(1.0-stereo**2) - spro(2,i)=stereo*sgn ! module measures both 'X' and 'Y' - sgn=-sgn ! stereo orientation - END IF - s=s+diss - END DO - - ! define broken lines - sold=-1000. - nbrl(1)=0 - nbrl(2)=0 - DO k=1,2 - DO i=1, nmlyr - IF (ABS(sarc(i)-sold) > cmbbrl(k)) nbrl(k)=nbrl(k)+1 - lb=nbrl(k) - lbrl(i,k)=lb - sbrl(lb,k)=sbrl(lb,k)+sarc(i) - wbrl(lb,k)=wbrl(lb,k)+1.0 - sold=sarc(i) - END DO - DO i=1,nbrl(k) - sbrl(i,k)=sbrl(i,k)/wbrl(i,k) - wbrl(i,k)=SQRT(wbrl(i,k)) - END DO - END DO - ibrl=imodel-2 - - ! misalign detector modules ----------------------------------------- - - dispxm=0.01 ! module displacement in X .05 mm * N(0,1) - dispym=0.01 ! module displacement in Y .05 mm * N(0,1) - - DO i=0,nlyr-1 - DO k=0,nmy-1 - DO l=1,nmx - sdevx(((i*nmy+k)*nmx+l))=dispxm*gran() ! shift in x - sdevy(((i*nmy+k)*nmx+l))=dispym*gran() ! shift in y - END DO - END DO - END DO - ! write text files ------------------------------------------------- - - IF(.NOT.ex1) THEN - luns=7 ! steerfile - WRITE(luns,101) '* Default test steering file' - WRITE(luns,101) 'fortranfiles ! following bin files are fortran' - WRITE(luns,101) 'mp2con.txt ! constraints text file ' - WRITE(luns,101) 'mp2tst.bin ! binary data file' - WRITE(luns,101) 'Cfiles ! following bin files are Cfiles' - ! WRITE(LUNS,101) '*outlierrejection 100.0 ! reject if Chi^2/Ndf >' - ! WRITE(LUNS,101) '*outliersuppression 3 ! 3 local_fit iterations' - - WRITE(luns,101) '*hugecut 50.0 !cut factor in iteration 0' - WRITE(luns,101) '*chisqcut 1.0 1.0 ! cut factor in iterations 1 and 2' - WRITE(luns,101) '*entries 10 ! lower limit on number of entries/parameter' - WRITE(luns,101) & - '*pairentries 10 ! lower limit on number of parameter pairs', & - ' ! (not yet!)' - WRITE(luns,101) '*printrecord 1 2 ! debug printout for records' - WRITE(luns,101) & - '*printrecord -1 -1 ! debug printout for bad data records' - WRITE(luns,101) & - '*outlierdownweighting 2 ! number of internal iterations (> 1)' - WRITE(luns,101) '*dwfractioncut 0.2 ! 0 < value < 0.5' - WRITE(luns,101) '*presigma 0.01 ! default value for presigma' - WRITE(luns,101) '*regularisation 1.0 ! regularisation factor' - WRITE(luns,101) '*regularisation 1.0 0.01 ! regularisation factor, pre-sigma' - - WRITE(luns,101) ' ' - WRITE(luns,101) '*bandwidth 0 ! width of precond. band matrix' - WRITE(luns,101) 'method diagonalization 3 0.001 ! diagonalization ' - WRITE(luns,101) 'method fullMINRES 3 0.01 ! minimal residual ' - WRITE(luns,101) 'method sparseMINRES 3 0.01 ! minimal residual ' - WRITE(luns,101) '*mrestol 1.0D-8 ! epsilon for MINRES' - WRITE(luns,101) 'method inversion 3 0.001 ! Gauss matrix inversion' - WRITE(luns,101) '* last method is applied' - WRITE(luns,101) '*matiter 3 ! recalculate matrix in iterations' - WRITE(luns,101) ' ' - WRITE(luns,101) 'end ! optional for end-of-data' - END IF - - ! constraints: fix center modules in first/last layer - - ncx=(nmx+1)/2 - nmxy=nmx*nmy - lunt=9 - one=1.0 - DO i=1,nlyr,nlyr-1 - IF(.NOT.ex2) WRITE(lunt,*) 'Constraint 0.0' - DO k=0,nmy-1 - labelt=(i*nmy+k)*nmx+ncx-1 - IF(.NOT.ex2) WRITE(lunt,103) labelt,one - sdevx(((i-1)*nmy+k)*nmx+ncx)=0.0 ! fix center modules at 0. - END DO - IF(.NOT.ex2) WRITE(lunt,*) 'Constraint 0.0' - DO k=0,nmy-1 - labelt=(i*nmy+k)*nmx+ncx+1000-1 - IF(.NOT.ex2) WRITE(lunt,103) labelt,one - sdevy(((i-1)*nmy+k)*nmx+ncx)=0.0 ! fix center modules at 0. - END DO - END DO - - ! record loop ------------------------------------------------------ - - ncount=10000 - nthits=0 - nrecds=0 - - DO icount=1,ncount - ! 10..100 GeV - p=10.0**(1.+uran()) - the0=SQRT(thck)*0.014/p - ip=0 - ! IF (ICOUNT.LE.3) IP=1 - CALL genln2(ip) ! generate hits - - - DO i=1,nhits - ! simple straight line - lyr=ihits(i)/nmxy+1 - im =MOD(ihits(i),nmxy) - nalc=4 - derlc(1)=spro(1,lyr) - derlc(2)=spro(2,lyr) - derlc(3)=xhits(i)*spro(1,lyr) - derlc(4)=xhits(i)*spro(2,lyr) - dergl(1)=spro(1,lyr) - dergl(2)=spro(2,lyr) - label(1)=im+nmxy*islyr(lyr) - label(2)=im+nmxy*islyr(lyr)+1000 - ! add multiple scattering errors (no correlations) - IF (imodel == 1) THEN - DO j=i,nhits - sigma(j)=SQRT(sigma(j)**2+((xhits(j)-xhits(i))*the0)**2) - END DO - END IF - ! add 'break points' for multiple scattering - IF (imodel == 2.AND.i > 1) THEN - DO j=1,i-1 - ! 2 scattering angles from each layer in front of current - nalc=nalc+1 - derlc(nalc)=(xhits(i)-xhits(j))*spro(1,lyr) - nalc=nalc+1 - derlc(nalc)=(xhits(i)-xhits(j))*spro(2,lyr) - END DO - END IF - ! add 'broken lines' offsets for multiple scattering - IF (imodel >= 3) THEN - nalc=2*nbrl(ibrl) - DO k=1, nalc - derlc(k)=0.0 - END DO - ! 2 offsets - lb=lbrl(lyr,ibrl) - derlc(lb*2-1)=spro(1,lyr) - derlc(lb*2 )=spro(2,lyr) - END IF - - CALL mille(nalc,derlc,2,dergl,label,yhits(i),sigma(i)) - nthits=nthits+1 ! count hits - END DO - ! additional measurements from MS - IF (imodel == 2) THEN - DO i=1,(nhits-1)*2 - nalc=i+4 - DO k=1,nalc - derlc(k)=0.0 - END DO - derlc(nalc)=1.0 - CALL mille(nalc,derlc,0,dergl,label,0.0,the0) - END DO - END IF - - IF (imodel >= 3) THEN - DO i=2,nbrl(ibrl)-1 - dp=1.0/(sbrl(i,ibrl)-sbrl(i-1,ibrl)) - dn=1.0/(sbrl(i+1,ibrl)-sbrl(i,ibrl)) - nalc=(i+1)*2 - DO l=-1,0 - DO k=1,nalc - derlc(k)=0.0 - END DO - derlc(2*(i-1)+l)= dp - derlc(2* i +l)=-dp-dn - derlc(2*(i+1)+l)= dn - CALL mille(nalc,derlc,0,dergl,label,0.0,the0*wbrl(i,ibrl)) - END DO - END DO - END IF - - CALL endle - nrecds=nrecds+1 ! count records - END DO - - ! ------------------------------------------------------------------ - IF(.NOT.ex1) THEN - REWIND (7) - CLOSE (7) - END IF - IF(.NOT.ex2) THEN - REWIND (9) - CLOSE (9) - END IF - REWIND (51) - CLOSE (51) - - ! WRITE(*,*) ' ' - ! WRITE(*,*) 'Shifts and drift velocity deviations:' - ! DO I=1,NPLAN - ! WRITE(*,102) I,DEL(I),DVD(I) - ! END DO - - - WRITE(*,*) ' ' - WRITE(*,*) ' ' - WRITE(*,*) ncount,' tracks generated with ',nthits,' hits.' - WRITE(*,*) nrecds,' records written.' - WRITE(*,*) ' ' -101 FORMAT(a) - ! 102 FORMAT(I6,2F10.5) -103 FORMAT(i8,f10.5) -END SUBROUTINE mptst2 - -!> Generate line and measurements. -!! -!! \param [in] ip print flag - -SUBROUTINE genln2(ip) - USE mptest2 - - IMPLICIT NONE - REAL(mps) :: ds - REAL(mps) :: dx - REAL(mps) :: dy - REAL(mps) :: gran - INTEGER(mpi) :: i - INTEGER(mpi) :: ihit - INTEGER(mpi) :: imx - INTEGER(mpi) :: imy - INTEGER(mpi) :: ioff - REAL(mps) :: sold - REAL(mps) :: uran - REAL(mps) :: x - REAL(mps) :: xexit - REAL(mps) :: xl - REAL(mps) :: xnull - REAL(mps) :: xs - REAL(mps) :: xslop - REAL(mps) :: y - REAL(mps) :: yexit - REAL(mps) :: yl - REAL(mps) :: ynull - REAL(mps) :: ys - REAL(mps) :: yslop - - - INTEGER(mpi), INTENT(IN) :: ip - - ! track parameters - xnull=sizel*(uran()-0.5) ! uniform vertex - ynull=sizel*(uran()-0.5) ! uniform vertex - xexit=sizel*(uran()-0.5) ! uniform exit point - yexit=sizel*(uran()-0.5) ! uniform exit point - xslop=(xexit-xnull)/sarc(nmlyr) - yslop=(yexit-ynull)/sarc(nmlyr) - IF(ip /= 0) THEN - WRITE(*,*) ' ' - WRITE(*,*) ' Track ', xnull, ynull, xslop, yslop - END IF - - nhits=0 - x=xnull - y=ynull - dx=xslop - dy=yslop - sold=0.0 - - DO i=1,nmlyr - ds=sarc(i)-sold - sold=sarc(i) - ! position with parameters 1. hit - xs=xnull+sarc(i)*xslop - ys=ynull+sarc(i)*yslop - ! true track position - x=x+dx*ds - y=y+dy*ds - ! multiple scattering - dx=dx+gran()*the0 - dy=dy+gran()*the0 - - imx=INT((x+sizel*0.5)/sizel*REAL(nmx,mps),mpi) - IF (imx < 0.OR.imx >= nmx) CYCLE - imy=INT((y+sizel*0.5)/sizel*REAL(nmy,mps),mpi) - IF (imy < 0.OR.imy >= nmy) CYCLE - - ihit=((i-1)*nmy+imy)*nmx+imx - ioff=((islyr(i)-1)*nmy+imy)*nmx+imx+1 - nhits=nhits+1 - ihits(nhits)=ihit - xl=x-sdevx(ioff) - yl=y-sdevy(ioff) - xhits(nhits)=sarc(i) - yhits(nhits)=(xl-xs)*spro(1,i)+(yl-ys)*spro(2,i)+gran()*ssig(i) - sigma(nhits)=ssig(i) - - IF(ip /= 0) THEN - WRITE(*,101) nhits,i,ihit,x,y,xhits(nhits), yhits(nhits),sigma(nhits) - END IF - END DO -101 FORMAT(3I3,5F8.4) -END SUBROUTINE genln2 - diff --git a/millepede/mptext.f90 b/millepede/mptext.f90 deleted file mode 100644 index 3add054829..0000000000 --- a/millepede/mptext.f90 +++ /dev/null @@ -1,387 +0,0 @@ - -! Code converted using TO_F90 by Alan Miller -! Date: 2012-03-16 Time: 11:09:16 - -!> \file -!! Analyse text string. -!! -!! \author Volker Blobel, University Hamburg, 2005-2009 (initial Fortran77 version) -!! \author Claus Kleinwort, DESY (maintenance and developement) -!! -!! \copyright -!! Copyright (c) 2009 - 2015 Deutsches Elektronen-Synchroton, -!! Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n -!! 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. \n\n -!! 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. \n\n -!! You should have received a copy of the GNU Library General Public -!! License along with this program (see the file COPYING.LIB for more -!! details); if not, write to the Free Software Foundation, Inc., -!! 675 Mass Ave, Cambridge, MA 02139, USA. -!! - -!> Keyword position. -MODULE mptext - USE mpdef - - IMPLICIT NONE - SAVE - INTEGER(mpi) :: keya !< start (position) of keyword - INTEGER(mpi) :: keyb !< end (position) of keyword - -END MODULE mptext - -!> Translate text. -!! -!! Translate TEXT into arrays of double precision numbers DNUMS(NUMS). -!! Text preceeding numbers is TEXT(KEYA:KEYB), if KEYB >= KEYA. -!! -!! \param[in] text text -!! \param[out] nums number of numbers found -!! \param[out] dnum array of numbers found - -SUBROUTINE ratext(text,nums,dnum) - USE mptext - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ia - INTEGER(mpi) :: ib - INTEGER(mpi) :: ic - INTEGER(mpi) :: ich - INTEGER(mpi) :: icl - INTEGER(mpi) :: icode - INTEGER(mpi) :: j - INTEGER(mpi) :: k - - INTEGER(mpi) :: lent - INTEGER(mpi) :: num - - CHARACTER (LEN=*), INTENT(IN) :: text - INTEGER(mpi), INTENT(OUT) :: nums - REAL(mpd), INTENT(OUT) :: dnum(*) - - INTEGER(mpi) :: last ! last non-blank character - INTEGER(mpi), PARAMETER :: ndim=1000 - INTEGER(mpi), DIMENSION(2,ndim):: icd - CHARACTER (LEN=16) :: keywrd - CHARACTER (LEN=1) :: ch - REAL(mpd) :: dic(ndim) - REAL(mpd) :: dumber - INTEGER(mpi) :: icdt(ndim) - SAVE - ! ... - nums=0 - last=0 - keya=0 - keyb=0 - IF(text(1:1) == '*') RETURN - num=ICHAR('0') - lent=0 - last=0 - DO i=1,LEN(text) ! find comment and end - IF(lent == 0.AND.(text(i:i) == '!'.OR.text(i:i) == '%')) lent=i - IF(text(i:i) /= ' ') last=i - END DO - IF(lent == 0) lent=last+1 - icd(1,1)=lent - - j=1 - icdt(1)=0 - icl=0 - DO i=1,lent-1 - ch =text(i:i) - ich=ICHAR(ch) - ic=0 - IF(ch == '.') ic=1 - IF(ch == '+') ic=2 - IF(ch == '-') ic=3 - IF(ch == 'E') ic=4 - IF(ch == 'D') ic=4 - IF(ch == 'e') ic=4 - IF(ch == 'd') ic=4 - IF(ic > 0) THEN - j=j+1 - icd(1,j)=i - icd(2,j)=i - icdt(j)=ic - ELSE - ic=6 - IF(ich >= num.AND.ich <= num+9) ic=5 ! digit - IF(ic /= icl) THEN - j=j+1 - icd(1,j)=i - icdt(j)=ic - END IF - icd(2,j)=i - END IF - icl=ic ! previous IC - END DO - icdt(j+1)=0 - - DO i=1,j ! define number - IF(icdt(i) == 5) THEN - dumber=0.0D0 - DO k=icd(1,i),icd(2,i) - dumber=10.0_mpd*dumber+REAL(ICHAR(text(k:k))-num,mpd) - END DO - dic(i)=dumber - END IF - END DO - icdt(j+1)=0 - - DO i=2,j ! get dots - IF(icdt(i) == 1) THEN - icode=0 - IF(icdt(i-1) == 5.AND.icd(2,i-1)+1 == icd(1,i)) icode=1 - IF(icdt(i+1) == 5.AND.icd(1,i+1)-1 == icd(2,i)) icode=icode+2 - IF(icode == 1) THEN ! 123. - icd(2,i-1)=icd(2,i) - icdt(i)=0 - ELSE IF(icode == 2) THEN ! .456 - dic(i)=10.0D0**(icd(1,i+1)-icd(2,i+1)-1)*dic(i+1) - icdt(i)=5 - icd(2,i)=icd(2,i+1) - icdt(i+1)=0 - ELSE IF(icode == 3) THEN ! 123.456 - dic(i-1)=dic(i-1)+ 10.0D0**(icd(1,i+1)-icd(2,i+1)-1)*dic(i+1) - icd(2,i-1)=icd(2,i+1) - icdt(i)=0 - icdt(i+1)=0 - END IF - END IF - END DO - - k=1 ! remove blanks, compress - DO i=2,j - IF(icdt(i) == 6.AND.text(icd(1,i):icd(2,i)) == ' ') icdt(i)=0 - IF(icdt(i) /= 0) THEN - k=k+1 - icd(1,k)=icd(1,i) - icd(2,k)=icd(2,i) - icdt(k)=icdt(i) - dic(k)=dic(i) - END IF - END DO - j=k - - DO i=2,j-1 - IF(icdt(i) == 2.OR.icdt(i) == 3) THEN ! +- - IF(icdt(i+1) == 5) THEN - icd(1,i+1)=icd(1,i) - IF(icdt(i) == 3) dic(i+1)=-dic(i+1) - icdt(i)=0 - END IF - END IF - END DO - - k=1 ! compress - DO i=2,j - IF(icdt(i) == 6.AND.text(icd(1,i):icd(2,i)) == ' ') icdt(i)=0 - IF(icdt(i) /= 0) THEN - k=k+1 - icd(1,k)=icd(1,i) - icd(2,k)=icd(2,i) - icdt(k)=icdt(i) - dic(k)=dic(i) - END IF - END DO - j=k - - DO i=2,j-1 - IF(icdt(i) == 4) THEN ! E or D - IF(icdt(i-1) == 5.AND.icdt(i+1) == 5) THEN - icd(2,i-1)=icd(2,i+1) - dic(i-1)=dic(i-1)*10.0D0**dic(i+1) - icdt(i)=0 - icdt(i+1)=0 - END IF - END IF - END DO - - nums=0 ! compress - DO i=1,j - IF(icdt(i) == 5) THEN - nums=nums+1 - icd(1,nums)=icd(1,i) - icd(2,nums)=icd(2,i) - dnum(nums)=dic(i) - END IF - END DO - - keywrd=' ' ! assemble keyword - ia=0 - ib=-1 - DO i=1,icd(1,1)-1 - IF(ia == 0.AND.text(i:i) /= ' ') ia=i - IF(text(i:i) /= ' ') ib=i - END DO - IF(ib >= 0) keywrd=text(ia:ib) - keya=ia - keyb=MAX(0,ib) -END SUBROUTINE ratext - -!> Analyse text range. -!! -!! \param[in] text text -!! \param[out] ia index of first non-blank character, or =1 -!! \param[out] ib index of last non-blank character, or =0 - comment excluded -!! \param[out] nab index of last non-blank character (=0 for blank text) - -SUBROUTINE rltext(text,ia,ib,nab) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: lim - - CHARACTER (LEN=*), INTENT(IN) :: text - INTEGER(mpi), INTENT(OUT) :: ia - INTEGER(mpi), INTENT(OUT) :: ib - INTEGER(mpi), INTENT(OUT) :: nab - - SAVE - ! ... - ia=0 - ib=0 - nab=0 - lim=0 - DO i=1,LEN(text) - IF(text(i:i) /= ' ') nab=i - IF((i == 1.AND.text(1:1) == '*').OR.text(i:i) == '!') THEN - IF(lim == 0) lim=i - END IF - END DO - IF(lim == 0) THEN - lim=nab - ELSE - lim=lim-1 - END IF - DO i=1,lim - IF(ia == 0.AND.text(i:i) /= ' ') ia=i - IF(text(i:i) /= ' ') ib=i - END DO -END SUBROUTINE rltext - -!> Approximate string matching. -!! -!! Approximate string matching - case insensitive. -!! Return number of matches of string PAT in string TEXT, -!! and number NPAT, NTEXT of characters of string PAT and string TEXT. -!! Strings are considered from first to last non-blank character. -!! -!! Example: -!! -!! MATCH = MATINT(' keYs ','keyWO RD',NPAT,NTEXT) -!! returns MATCH=3, NPAT=4, NTEXT=8 -!! -!! \param[in] pat pattern -!! \param[in] text text -!! \param[out] npat number of characters in pattern -!! \param[out] ntext number of characters in text -!! \return number of matching characters of pattern in text - -INTEGER(mpi) FUNCTION matint(pat,text,npat,ntext) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ic - INTEGER(mpi) :: ideq - INTEGER(mpi) :: ip - INTEGER(mpi) :: ipa - INTEGER(mpi) :: ipb - INTEGER(mpi) :: ita - INTEGER(mpi) :: itb - INTEGER(mpi) :: j - INTEGER(mpi) :: jc - INTEGER(mpi) :: jot - INTEGER(mpi) :: jt - INTEGER(mpi) :: npatma - - CHARACTER (LEN=*), INTENT(IN) :: pat - CHARACTER (LEN=*), INTENT(IN) :: text - INTEGER(mpi), INTENT(OUT) :: npat - INTEGER(mpi), INTENT(OUT) :: ntext - - !GF - ! INTEGER ID(0:100,2) - PARAMETER (npatma=512) - INTEGER(mpi) :: id(0:npatma,2) - ! end GF - LOGICAL :: start ! for case conversion - CHARACTER (LEN=26) :: chu - CHARACTER (LEN=26) :: chl - INTEGER(mpi) :: nj(0:255) - SAVE - DATA chu/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ - DATA chl/'abcdefghijklmnopqrstuvwxyz'/ - DATA start/.TRUE./ - DATA nj/256*0/ - ! ... - IF(start) THEN - start=.FALSE. - DO j=0,255 - nj(j)=j - END DO - DO i=1,26 - nj(ICHAR(chl(i:i)))=ICHAR(chu(i:i)) - END DO - END IF - ! ... - matint=0 - ntext=0 - DO i=1,LEN(text) ! find indices ITA...ITB - IF(text(i:i) /= ' ') GO TO 10 - END DO - GO TO 15 -10 ita=i - DO i=ita,LEN(text) - IF(text(i:i) /= ' ') itb=i - END DO - ntext=itb-ita+1 ! number of charcaters in TEXT - -15 npat=0 - DO i=1,LEN(pat) ! find indices IPA...IPB - IF(pat(i:i) /= ' ') GO TO 20 - END DO - RETURN -20 ipa=i - DO i=ipa,LEN(pat) - IF(pat(i:i) /= ' ') ipb=i - END DO - npat=ipb-ipa+1 - !GF IF(NPAT.GT.100) STOP 'MATINT: string PAT too long! ' - IF(npat > npatma) THEN - WRITE(*,*) 'too long PAT (', pat,'):', npat, ' >', npatma - CALL peend(34,'Aborted, pattern string too long') - STOP 'MATINT: string PAT too long! ' - END IF - !GF end - id(0,1)=0 - DO i=0,npat - id(i,2)=i - END DO - jot=2 - - DO j=1,ntext - jot=3-jot - jt=j+ita-1 - jc=nj(ICHAR(text(jt:jt))) - DO i=1,npat - ip=i+ipa-1 - ideq=id(i-1,3-jot) - ic=nj(ICHAR(pat(ip:ip))) - IF(ic /= jc) ideq=ideq+1 - id(i,jot)=MIN(ideq,id(i,3-jot)+1,id(i-1,jot)+1) - END DO - matint=MAX(matint,npat-id(npat,jot)) - END DO -END FUNCTION matint - - diff --git a/millepede/pede.f90 b/millepede/pede.f90 deleted file mode 100644 index 73e2df42f4..0000000000 --- a/millepede/pede.f90 +++ /dev/null @@ -1,9076 +0,0 @@ - -! Code converted using TO_F90 by Alan Miller -! Date: 2012-03-16 Time: 11:06:00 - -!> \file -!! Millepede II program, subroutines. -!! -!! \author Volker Blobel, University Hamburg, 2005-2009 (initial Fortran77 version) -!! \author Gero Flucke, University Hamburg (support of C-type binary files) -!! \author Claus Kleinwort, DESY (maintenance and developement) -!! -!! \copyright -!! Copyright (c) 2009 - 2018 Deutsches Elektronen-Synchroton, -!! Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n -!! 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. \n\n -!! 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. \n\n -!! You should have received a copy of the GNU Library General Public -!! License along with this program (see the file COPYING.LIB for more -!! details); if not, write to the Free Software Foundation, Inc., -!! 675 Mass Ave, Cambridge, MA 02139, USA. -!! - -!> \mainpage Overview -!! -!! \section intro_sec Introduction -!! In certain least squares fit problems with a very large number of parameters -!! the set of parameters can be divided into two classes, global and local parameters. -!! Local parameters are those parameters which are present only in subsets of the -!! data. Detector alignment and calibration based on track fits is one of the problems, -!! where the interest is only in optimal values of the global parameters, the -!! alignment parameters. The method, called Millepede, to solve the linear least -!! squares problem with a simultaneous fit of all global and local parameters, -!! irrespectively of the number of local parameters, is described in the draft manual. -!! -!! The Millepede method and the initial implementation has been -!! developed by [V. Blobel](http://www.desy.de/~blobel) from he University of Hamburg. -!! Meanwhile the code is maintained at DESY by the statistics tools group of the -!! analysis center of the Helmholtz Terascale alliance -!! ([www.terascale.de](https://www.wiki.terascale.de/index.php/Millepede_II)). -!! -!! The Millepede II software is provided by DESY under the terms of the -!! [LGPLv2 license](http://www.gnu.org/licenses/old-licenses/lgpl-2.0-standalone.html). -!! -!! \section install_sec Installation -!! To install **Millepede** (on a linux system): -!! 1. Download the software package from the DESY \c svn server to -!! \a target directory, e.g.: -!! -!! svn checkout http://svnsrv.desy.de/public/MillepedeII/tags/V04-04-01 target -!! -!! 2. Create **Pede** executable (in \a target directory): -!! -!! make pede -!! -!! 3. Optionally check the installation by running the simple test case: -!! -!! ./pede -t -!! -!! This will create (and use) the necessary text and binary files. -!! -!! \section news_sec News -!! * 131008: New solution method \ref ch-minresqlp "MINRES-QLP" -!! [\ref ref_sec "ref 9"] implemented. -!! * 140226: Reading of C binary files containing *doubles* implemented. -!! * 141020: Storage of values read from text files as *doubles* implemented. -!! * 141125: Dynamic entries (from accepted local fits) check implemented. -!! (Rejection of local fits may lead to the loss of degrees of freedom.) -!! Printout of global parameter counters with new command \ref cmd-printcounts. -!! * 141126: Weighted constraints implemented (with new command \ref cmd-weightedcons). -!! * 150210: Solution by elimination for problems with linear equality constraints -!! has been implemented (as default, new command \ref cmd-withelim) in addition to the -!! Lagrange multiplier method (new command \ref cmd-withmult). -!! * 150218: Skipping *empty* constraints (without variable parameters). -!! With new command \ref cmd-checkinput detailed check of input data (binary files, -!! constraints) is performed, but no solution will be determined. -!! Some input statistics is available in the output file millepede.res. -!! * 150226: Iteration of entries cut with new command \ref cmd-iterateentries. -!! In the second iteration measurements with any parameters fixed by the -!! previous entries cut are skipped. Useful if parameters of measurements have -!! different number of entries. -!! * 150420: Skipping of empty constraints has to be enabled by new command \ref -!! cmd-skipemptycons. -!! * 150901: Preconditioning for MINRES with skyline matrix (avoiding rank deficits -!! of band matrix) added (selected by second argument in \ref cmd-bandwidth >0). -!! * 150925: Monitoring of residuals per local fit cycle is selected by \ref cmd-monres. -!! The normalized residuals are grouped by the first global label and the median -!! and the RMS (from the median of the absolute deviations) per group are -!! written to millepede.mon. -!! * 170502: Monitoring of pulls per local fit cycle is selected by \ref cmd-monpull. -!! The scaling of measurement errors is enabled by \ref cmd-scaleerrors. -!! Pede will abort now for constraints with a singular QL decomposition -!! of the constraints matrix (solution by elemination). -!! This problem is usually caused by *empty* constraints (see \ref -!! cmd-skipemptycons). -!! * 170831: More debug information for problems with reading Cfiles. Don't stop -!! after read error for \ref cmd-checkinput mode. -!! * 180525: Some fixes: Proper handling of special (debug) data blocks in binary -!! files, proper exit code (3) for 'function not decreasing'. -!! * 180815: Some minor fixes, additional level of detail (appearance range of global -!! parameters in binary files) for \ref cmd-checkinput mode. -!! * 190319: Constraints are now sorted and split into disjoint blocks to speed up -!! calculation of rank and QL decomposition by block matrix algebra. -!! This works best if the label sets of the involved alignable objects are disjoint too. -!! * 190412: Cleanup of operations (open, close, rewind) on binary files. New command -!! \ref cmd-closeandreopen to to enable closing and reopening of binary files -!! to limit the number of concurrently open files. The modification dates of the -!! files are monitored to ensure data integrity. -!! -!! \section tools_sec Tools -!! The subdirectory \c tools contains some useful scripts: -!! * \c readMilleBinary.py: Python script to read binary files and print -!! records in text form. -!! * \c readPedeHists.C: ROOT script to read and convert the **Millepede** -!! histogram file millepede.his. -!! -!! \section details_sec Details -!! -!! Detailed information is available at: -!! -!! \subpage draftman_page -!! -!! \subpage changes_page -!! -!! \subpage option_page -!! -!! \subpage exit_code_page -!! -!! \section Contact -!! -!! For information exchange the **Millepede** mailing list -!! anacentre-millepede2@desy.de should be used. -!! -!! \section ref_sec References -!! -!! 1. A New Method for the High-Precision Alignment of Track Detectors, -!! Volker Blobel and Claus Kleinwort, Proceedings of the Conference on -!! Adcanced Statistical Techniques in Particle Physics, Durham, 18 - 22 March 2002, -!! Report DESY 02-077 (June 2002) and -!! [hep-ex/0208021](http://arxiv.org/abs/hep-ex/0208021) -!! 2. Alignment Algorithms, V. Blobel, -!! [Proceedings](http://cdsweb.cern.ch/search?p=reportnumber%3ACERN-2007-004) -!! of the LHC Detector Alignment Workshop, September 4 - 6 2006, CERN -!! 3. Software alignment for Tracking Detectors, V. Blobel, -!! NIM A, 566 (2006), pp. 5-13, -!! [doi:10.1016/j.nima.2006.05.157](http://dx.doi.org/10.1016/j.nima.2006.05.157) -!! 4. A new fast track-fit algorithm based on broken lines, V. Blobel, -!! NIM A, 566 (2006), pp. 14-17, -!! [doi:10.1016/j.nima.2006.05.156](http://dx.doi.org/10.1016/j.nima.2006.05.156) -!! 5. Millepede 2009, V. Blobel, [Contribution] -!! (https://indico.cern.ch/conferenceOtherViews.py?view=standard&confId=50502) -!! to the 3rd LHC Detector Alignment Workshop, June 15 - 16 2009, CERN -!! 6. General Broken Lines as advanced track fitting method, C. Kleinwort, -!! NIM A, 673 (2012), pp. 107-110, -!! [doi:10.1016/j.nima.2012.01.024](http://dx.doi.org/10.1016/j.nima.2012.01.024) -!! 7. Volker Blobel und Erich Lohrmann, Statistische und numerische Methoden der -!! Datenanalyse, Teubner Studienbücher, B.G. Teubner, Stuttgart, 1998. -!! [Online-Ausgabe](http://www.desy.de/~blobel/eBuch.pdf). -!! 8. [Systems Optimization Laboratory](http://web.stanford.edu/group/SOL/software/minres), -!! Stanford University;\n -!! C. C. Paige and M. A. Saunders (1975), -!! Solution of sparse indefinite systems of linear equations, -!! SIAM J. Numer. Anal. 12(4), pp. 617-629. -!! 9. [Systems Optimization Laboratory](http://web.stanford.edu/group/SOL/software/minresqlp), -!! Stanford University;\n -!! Sou-Cheng Choi, Christopher Paige, and Michael Saunders, -!! MINRES-QLP: A Krylov subspace method for indefinite or singular -!! symmetric systems, SIAM Journal of Scientific Computing 33:4, 1810-1836, 2011, -!! [doi:10.1137/100787921](http://dx.doi.org/10.1137/100787921) -!! - -!> \page changes_page Major changes -!! Major changes with respect to the \ref draftman_page "draft manual". -!! \tableofcontents -!! -!! \section ch-methods Solution methods -!! The following methods to obtain the solution \f$\Vek{x}\f$ from a -!! linear equation system \f$\Vek{A}\cdot\Vek{x}=\Vek{b}\f$ are implemented: -!! \subsection ch-inv Inversion -!! The solution and the covariance matrix \f$\Vek{A}^{-1}\f$ are obtained by -!! \ref an-inv "inversion" of \f$\Vek{A}\f$. -!! Available are the value, error and global correlation for all global parameters. -!! The matrix inversion \ref sqminl "routine" has been \ref ch-openmp "parallelized" -!! and can be used for up to several 10000 parameters. -!! \subsection ch-diag Diagonalization -!! The solution and the covariance matrix \f$\Vek{A}^{-1}\f$ are obtained by -!! \ref an-diag "diagonalization" of \f$\Vek{A}\f$. -!! Available are the value, error, global correlation and -!! eigenvalue (and eigenvector) for all global parameters. -!! \subsection ch-minres Minimal Residual Method (MINRES) -!! The solution is obtained by minimizing \f$\Vert\Vek{A}\cdot\Vek{x}-\Vek{b}\Vert_2\f$ -!! iteratively. \ref minresmodule::minres "MINRES" [\ref ref_sec "ref 8"] is a special case of the -!! generalized minimal residual method (\ref an-gmres "GMRES") for symmetric matrices. -!! Preconditioning with a band matrix of zero or finite -!! \ref mpmod::mbandw "bandwidth" is possible. -!! Individual columns \f$\Vek{c_i}\f$ of the covariance matrix can be calculated by -!! solving \f$\Vek{A}\cdot\Vek{c}_i=\Vek{1}_i\f$ where \f$\Vek{1}_i\f$ is the i-th -!! column on the unit matrix. -!! The most time consuming part (\ref avprod "product" matrix times vector per iteration) -!! has been \ref ch-openmp "parallelized". -!! Available are the value for all (and optionally error, global correlation -!! for few) global parameters. -!! \subsection ch-minresqlp Advanced Minimal Residual Method (MINRES-QLP) -!! The \ref minresqlpmodule::minresqlp "MINRES-QLP" implementation [\ref ref_sec "ref 9"] -!! is a MINRES evolution with improved norm estimates and stopping conditions -!! (leading potentially to different numbers of internal iterations). -!! Internally it uses QLP instead of the QR factorization in -!! MINRES which should be numerically superior and allows to find for -!! singular systems the minimal length (pseudo-inverse) solution. -!! -!! The default behavior is to start (the internal iterations) with QR factorization -!! and to switch to QLP if the (estimated) matrix condition exceeds -!! \ref cmd-mrestranscond "mrtcnd". Pure QR or QLP factorization can be enforced -!! by \ref cmd-mresmode "mrmode". -!! -!! \subsection ch-elim-const Elimination of constraints -!! As alternative to the Lagrange multiplier method the solution by elimination -!! has been added for problems with linear equality constraints. -!! A \ref mpqldec::qldec "QL factorization" (with Householder reflections) of the -!! transposed constraints matrix is used to transform to an unconstrained problem. -!! For sparse matrix storage the sparsity of the global matrix is preserved. -!! -!! \section ch-regul Regularization -!! Optionally a term \f$\tau\cdot\Vert\Vek{x}\Vert\f$ can be added to the objective function -!! (to be minimized) where \f$\Vek{x}\f$ is the vector of global parameters -!! weighted with the inverse of their individual pre-sigma values. -!! -!! \section ch-locfit Local fit -!! In case the \ref par-locfitv "local fit" is a track fit with proper description of multiple -!! scattering in the detector material additional local parameters have to be introduced -!! for each scatterer and solution by *inversion* can get time consuming -!! (~ \f$n_{lp}^3\f$ for \f$n_{lp}\f$ local parameters). For trajectories based on -!! **broken lines** [\ref ref_sec "ref 4,6"] the corresponding matrix \f$\Vek{\Gamma}\f$ -!! has a bordered band structure (\f$\Gamma_{ij}=0\f$ for \f$\min(i,j)>b\f$ -!! (border size) and \f$|i-j|>m\f$ (bandwidth)). With -!! root-free Cholesky decomposition the time for the solution is linear -!! and for the calculation of \f$\Gamma^{-1}\f$ -!! (needed for the construction of the global matrix) quadratic in \f$n_{lp}\f$. -!! For each local fit the structure of \f$\Vek{\Gamma}\f$ is checked and the faster -!! solution method selected automatically. -!! -!! \section ch-openmp Parallelization -!! The code has been largely parallelized using [OpenMP&tm;](www.openmp.org). -!! This includes the reading of binary files, the local fits, the construction of the -!! sparsity structure and filling of the global matrix and the global fit -!! (except by diagonalization). The number of threads is set by the command -!! \ref cmd-threads. -!! -!! \b Caching. The records are read in blocks into a *read cache* and processed from -!! there in parallel, each record by a single thread. For the filling of the global -!! matrix the (zero-compressed) update matrices (\f$\Vek{\D C}_1+\Vek{\D C}_2\f$ from -!! equations \ref eq-c1 "(15)", \ref eq-c2 "(16)") -!! produced by each local fit are collected in a -!! *write cache*. After processing the block of records this is used to update -!! the global matrix in parallel, each row by a single thread. -!! The total cache size can be changed by the command \ref cmd-cache. -!! -!! \section ch-compression Compressed sparse matrix -!! In sparse storage mode for each row the list of column indices (and values) for the -!! non-zero elements are stored. With compression regions of continous column indices -!! are represented by the first index and their number (packed into a single 32bit -!! integer). Compression is selected by the command \ref cmd-compress. -!! In addition rare elements can be neglected (,histogrammed) or stored in single instead -!! of double precision according to the \ref cmd-pairentries command. -!! -!! \section ch-gzip Gzipped C binary files -!! The [zlib](zlib.net) can be used to directly read *gzipped* C binary files. -!! In this case reading with multiple threads -!! (each file by single thread) can speed up the decompression. -!! -!! \section ch-transf Transformation from FORTRAN77 to Fortran90 -!! The **Millepede** source code has been formally transformed from fixed form -!! FORTRAN77 to free form Fortran90 (using TO_F90 by Alan Miller) -!! and (most parts) modernized: -!! - IMPLICIT NONE everywhere. Unused variables removed. -!! - \c COMMON blocks replaced by \c MODULEs. -!! - Backward \c GOTOs replaced by proper \c DO loops. -!! - \c INTENT (input/output) of arguments described. -!! - Code documented with doxygen. -!! -!! Unused parts of the code (like the interactive mode) have been removed. -!! The reference compiler for the Fortran90 version is gcc-4.6.2 (gcc-4.4.4 works too). -!! -!! \section ch-memmanage Memory management -!! The memory management for dynamic data structures (matrices, vectors, ..) -!! has been changed from a \ref an-dynal "subdivided" *static* \c COMMON block to -!! *dynamic* (\c ALLOCATABLE) Fortran90 arrays. One **Pede** executable is now -!! sufficient for all application sizes. -!! -!! \section ch-readbuf Read buffer size -!! In the \ref sssec-loop1 "first loop" over all binary files a preset -!! \ref mpmod::ndimbuf "read buffer size" is used. Too large records are skipped, -!! but the maximal record length is still being updated. If any records had to be skipped -!! the read buffer size is afterwards adjusted according to the maximal record length -!! and the first loop is repeated. -!! -!! \section ch-numbin Number of binary files -!! The number of binary files has no hard-coded limit anymore, but is calculated from -!! the steering file and resources (file names, descriptors, ..) -!! are allocated dynamically. Some resources may be limited by the system. -!! - -!> \page option_page List of options and commands -!! -!! \tableofcontents -!! -!! \section sec-opt Command line options: -!! \subsection opt-t1 -t -!! Create text and binary files for \ref mptest1.f90 "wire chamber" test case, set -!! \ref mpmod::ictest "ictest" to 1. -!! \subsection opt-t2 -t=track-model -!! Create text and binary files for \ref mptest2.f90 "silicon strip tracker" test case -!! using \a track-models with different accounting for multiple scattering, set -!! \ref mpmod::ictest "ictest" to 2..6. -!! \subsection opt-s -s -!! Solution is not iterated. -!! Automatically switched on in case of rank deficits for constraints. -!! \subsection opt-f -f -!! Force iterating of solution (in case of rank deficits for constraints). -!! \subsection opt-c -c -!! Check input (binary files, constraints). No solution is determined. (\ref mpmod::icheck "icheck"=1) -!! \subsection opt-C -C -!! Check input (binary files, constraints, appearance). No solution is determined. (\ref mpmod::icheck "icheck"=2) -!! -!! \section sec-cmd Steering file commands: -!! In general the commands are defined by a single line: -!! -!! keyword number1 number2 ... -!! -!! For those specifying \ref sssec-parinf "properties" of the global parameters -!! (\a keyword = \c parameter, \c constraint or \c measurement) -!! for each involved global parameter (identified by a \ref an-glolab "label") -!! one additional line follows: -!! -!! label number1 number2 ... -!! -!! Default values for the numerical arguments are shown in -!! the command descriptions in '[]'. Missing arguments without default -!! values have no effect. -!! -!! \subsection cmd-bandwidth bandwidth -!! Set band width \ref mpmod::mbandw "mbandw" for -!! \ref minresmodule::minres "MINRES" preconditioner to \a number1 [0] -!! and additional flag \ref mpmod::lprecm "lprecm" to \a number2 [0]. -!! \subsection cmd-cache cache -!! Set (read+write) cache size \ref mpmod::ncache "ncache" to \a number1. -!! Define cache size and average fill level. -!! \subsection cmd-cfiles Cfiles -!! Following binaries are C files. -!! \subsection cmd-checkinput checkinput -!! Set check input flag \ref mpmod::icheck "icheck" to \a number1 [1]. -!! Similar to \ref opt-c "-c" or \ref opt-C "-C". -!! For mpmod::icheck "icheck" >0 no solution is performed but input statistics is checked in detail. -!! With mpmod::icheck "icheck" >1 the appearance range (first/last file,record and number of files) -!! of global parameters is determined too. -!! \subsection cmd-chisqcut chisqcut -!! For local fit \ref an-chisq "setChi^2" cut \ref mpmod::chicut "chicut" to \a number1 [1.], -!! \ref mpmod::chirem "chirem" to \a number2 [1.]. -!! \subsection cmd-compress compress -!! Set compression flag \ref mpmod::mcmprs "mcmprs" for \ref mpbits.f90 "sparse storage" -!! to 1 (true) (and \ref mpmod::msngpe "msngpe" to 1). -!! \subsection cmd-closeandreopen closeandreopen -!! Set flag \ref mpmod::keepopen "keepOpen" to zero to enable closing and reopening of binary files -!! to limit the number of concurrently open files. -!! \subsection cmd-constraint constraint -!! Define \ref sssec_consinf "constraints" for global parameters. -!! \subsection cmd-debug debug -!! Set number of records with debug printout \ref mpmod::mdebug "mdebug" to -!! \a number1 [3], number of measurements with printout \ref mpmod::mdebg2 "mdebg2" to \a number2. -!! \subsection cmd-dwfractioncut dwfractioncut -!! Set \ref an-dwcut "down-weighting fraction" cut \ref mpmod::dwcut "dwcut" -!! to \a number1 (max. 0.5). -!! \subsection cmd-entries entries -!! Set \ref an-entries "entries" cuts for variable global parameter -!! \ref mpmod::mreqenf "mreqenf" to \a number1 [25], -!! \ref mpmod::mreqena "mreqena" to \a number2 [10] and -!! \ref mpmod::iteren "iteren" to the product of \a number1 and \a number3 [0]. -!! \subsection cmd-errlabels errlabels -!! Define (up to 100 in total) global labels \a number1 .. \a numberN -!! for which the parameter errors are calculated for method MINRES too -!! (by \ref solglo "solving" \f$\Vek{C}\cdot\Vek{x}_i = \Vek{b}^i, b^i_j = \delta_{ij} \f$). -!! \subsection cmd-force force -!! Set force (iterations) flag \ref mpmod::iforce "iforce" to 1 (true). -!! Same as \ref opt-f "-f". -!! \subsection cmd-fortranfiles fortranfiles -!! Following binaries are Fortran files. -!! \subsection cmd-globalcorr globalcorr -!! Set flag \ref mpmod::igcorr "igcorr" for output of global correlations to 1 (true). -!! \subsection cmd-histprint histprint -!! Set flag \ref mpmod::nhistp "nhistp" for \ref an-histpr "histogram printout" -!! to 1 (true). -!! \subsection cmd-hugecut hugecut -!! For local fit set Chi^2 cut \ref mpmod::chhuge "chhuge" -!! for \ref sssec-outlierdeb "unreasonable data" to \a number1 [1.]. -!! \subsection cmd-iterateentries iterateentries -!! Set maximum value \ref mpmod::iteren "iteren" for iteration of entries cut to -!! \a number1 [maxint]. Can alternatively be set by the \ref cmd-entries command. -!! For parameters with less entries the cut will be iterated ignoring measurements with -!! at least one parameter below \ref mpmod::mreqenf "mreqenf". -!! \subsection cmd-linesearch linesearch -!! The mode \ref mpmod::lsearch "lsearch" of the \ref par-linesearch "line search" -!! to improve the solution is set to \a number1. -!! \subsection cmd-localfit localfit -!! For local fit set number of iterations \ref mpmod::lfitnp "lfitnp" -!! with calculation of pulls to \a number1, flag \ref mpmod::lfitbb "lfitbb" -!! for auto-detection of bordered band matrices to \a number2. -!! \subsection cmd-matiter matiter -!! Set number of iterations \ref mpmod::matrit "matrit" with (re)calcuation of -!! global matrix to \a number1. -!! \subsection cmd-matmoni matmoni -!! Set record interval \ref mpmod::matmon "matmon" for monitoring of (sparse) matrix -!! construction to \a number1. -!! \subsection cmd-maxrecord maxrecord -!! Set record limit \ref mpmod::mxrec "mxrec" to \a number1. -!! \subsection cmd-measurement measurement -!! Define (additional) \ref sssec_gpm "measurements" for global parameters. -!! \subsection cmd-memorydebug memorydebug -!! Set debug flag \ref mpmod::memdbg "memdbg" for memory management -!! to \a number1 [1]. -!! \subsection cmd-method method -!! Has special format: -!! -!! method name number1 number2 -!! -!! Set \ref ch-methods "solution method" \ref mpmod::metsol "metsol" and -!! storage mode \ref mpmod::matsto "matsto" according to \a name, -!! (\c inversion : (1,1), \c diagonalization : (2,1), -!! \c fullMINRES : (3,1) or \c sparseMINRES : (3,2), -!! \c fullMINRES-QLP : (4,1) or \c sparseMINRES-QLP : (4,2)), -!! (minimum) number of iterations \ref mpmod::mitera "mitera" to \a number1, -!! convergence limit \ref mpmod::dflim "dflim" to \a number2. -!! \subsection cmd-monres monitorresiduals -!! Set flag \ref mpmod::imonit "imonit" for monitoring of residuals to \a number1 [3] -!! and increase number of bins (of size 0.1) for internal storage to \a number2 [100]. -!! Monitoring mode \ref mpmod::imonmd "imonmd" is 0. -!! \subsection cmd-monpull monitorpulls -!! Set flag \ref mpmod::imonit "imonit" for monitoring of pulls to \a number1 [3] -!! and increase number of bins (of size 0.1) for internal storage to \a number2 [100]. -!! Monitoring mode \ref mpmod::imonmd "imonmd" is 1. -!! \subsection cmd-mresmode mresmode -!! Set \ref minresqlpmodule::minresqlp "MINRES-QLP" factorization mode -!! \ref mpmod::mrmode "mrmode" to \a number1. -!! \subsection cmd-mrestranscond mrestranscond -!! Set \ref minresqlpmodule::minresqlp "MINRES-QLP" transition (matrix) condition -!! \ref mpmod::mrtcnd "mrtcnd" to \a number1. -!! \subsection cmd-mrestol mrestol -!! Set tolerance criterion \ref mpmod::mrestl "mrestl" for \ref minresmodule::minres "MINRES" -!! to \a number1 (\f$10^{-10}\f$ .. \f$10^{-4}\f$). -!! \subsection cmd-nofeasiblestart nofeasiblestart -!! Set flag \ref mpmod::nofeas "nofeas" for \ref an-nofeas "skipping" -!! making parameters feasible to \a number1 [1]. -!! \subsection cmd-outlierdownweighting outlierdownweighting -!! For local fit set number of \ref sssec-outlow "outlier" -!! \ref an-downw "down-weighting" iterations -!! \ref mpmod::lhuber "lhuber" to \a number1. -!! \subsection cmd-pairentries pairentries -!! Set entries cut for variable global parameter pairs \ref mpmod::mreqpe "mreqpe" -!! to \a number1, histogram upper bound \ref mpmod::mhispe "mhispe" for pairs -!! to \a number2 (<1: no histogramming), upper bound \ref mpmod::msngpe "msngpe" -!! for pair entries with single precision storage -!! to \a number3. -!! \subsection cmd-parameter parameter -!! Define \ref sssec-parinf "initial value, pre-sigma" for global parameters. -!! \subsection cmd-presigma presigma -!! Set default pre-sigma \ref mpmod::regpre "regpre" to \a number1 [1]. -!! \subsection cmd-print print -!! Set print level \ref mpmod::mprint "mprint" to \a number1 [1]. -!! \subsection cmd-printcounts printcounts -!! Set flag \ref mpmod::ipcntr "ipcntr" to \a number1 [1]. -!! The counters for the global parameters from the accepted local fits (=1) -!! or from the binary files (>1) will be printed in the result file. -!! \subsection cmd-printrecord printrecord -!! \ref an-recpri "Record" numbers with printout. -!! \subsection cmd-pullrange pullrange -!! Set (symmetric) range \ref mpmod::prange "prange" for histograms -!! of pulls, normalized residuals to \a number1 (=0: auto-ranging). -!! \subsection cmd-regularisation regularisation -!! Set flag \ref mpmod::nregul "nregul" for regularization to 1 (true), -!! regularization parameter \ref mpmod::regula "regula" to \a number2, -!! default pre-sigma \ref mpmod::regpre "regpre" to \a number3. -!! \subsection cmd-regularization regularization -!! Set flag \ref mpmod::nregul "nregul" for regularization to 1 (true), -!! regularization parameter \ref mpmod::regula "regula" to \a number2, -!! default pre-sigma \ref mpmod::regpre "regpre" to \a number3. -!! \subsection cmd-scaleerrors scaleerrors -!! Set measurement scaling factors \ref mpmod::dscerr "dscerr" -!! to \a number1 [1.] and \a number2 [\a number1]. -!! First value is for "global" measurements (with global derivatives), -!! second for "local" measurements (without global derivatives). -!! \subsection cmd-skipemptycons skipemptycons -!! Set flag \ref mpmod::iskpec "iskpec" to 1 (true). -!! Empty constraints (without variable parameters) will be skipped. -!! \subsection cmd-subito subito -!! Set subito (no iterations) flag \ref mpmod::isubit "isubit" to 1 (true). -!! Same as \ref opt-s "-s". -!! \subsection cmd-threads threads -!! Set number \ref mpmod::mthrd "mthrd" of OpenMP&tm; threads for processing -!! to \a number1, -!! number \ref mpmod::mthrdr "mthrdr" of threads for reading -!! binary files to \a number2 [\a number1]. -!! \subsection cmd-weightedcons weightedcons -!! Set flag \ref mpmod::iwcons "iwcons" to \a number1 [1]. -!! Implements \ref sssec_consinf "weighted constraints" for global parameters. -!! \subsection cmd-withelim withelimination -!! Set flag \ref mpmod::icelim "icelim" to 1 (true). -!! Selects solution by elimination for linear equality constraints. -!! \subsection cmd-withmult withmultipliers -!! Set flag \ref mpmod::icelim "icelim" to 0 (false). -!! Selects solution by Lagrange multipliers for linear equality constraints. -!! \subsection cmd-wolfe wolfe -!! For strong Wolfe condition in \ref par-linesearch "line search" -!! set parameter \ref mpmod::wolfc1 "wolfc1" to \a number1, \ref mpmod::wolfc2 -!! "wolfc2" to \a number2. - -!> \page exit_code_page List of exit codes -!! The exit code and message of the **Pede** executable can be found in the -!! file millepede.end : -!! + -1 Still running or crashed -!! + **00** Ended normally -!! + **01** Ended with warnings (bad measurements) -!! + **02** Ended with severe warnings (insufficient measurements) -!! + **03** Ended with severe warnings (bad global matrix) -!! + **10** Aborted, no steering file -!! + **11** Aborted, open error for steering file -!! + **12** Aborted, second text file in command line -!! + **13** Aborted, unknown keywords in steering file -!! + **14** Aborted, no binary files -!! + **15** Aborted, open error(s) for binary files -!! + **16** Aborted, open error(s) for text files -!! + **17** Aborted, file name too long -!! + **18** Aborted, read error(s) for binary files -!! + **19** Aborted, binary file(s) modified -!! + **20** Aborted, bad binary records -!! + **21** Aborted, no labels/parameters defined -!! + **22** Aborted, no variable global parameters -!! + **23** Aborted, bad matrix index -!! + **24** Aborted, vector/matrix size mismatch -!! + **25** Aborted, result vector contains NaNs -!! + **26** Aborted, too many rejects -!! + **27** Aborted, singular QL decomposition of constraints matrix -!! + **30** Aborted, memory allocation failed -!! + **31** Aborted, memory deallocation failed -!! + **32** Aborted, iteration limit reached in diagonalization -!! + **33** Aborted, stack overflow in quicksort -!! + **34** Aborted, pattern string too long - -!> Millepede II main program \ref sssec-stalone "Pede". -PROGRAM mptwo - USE mpmod - USE mpdalc - USE mptest1, ONLY: nplan,del,dvd - USE mptest2, ONLY: nlyr,nmx,nmy,sdevx,sdevy - - IMPLICIT NONE - REAL(mps) :: andf - REAL(mps) :: c2ndf - REAL(mps) :: deltat - REAL(mps) :: diff - REAL(mps) :: err - REAL(mps) :: gbu - REAL(mps) :: gmati - REAL(mps) :: rej - REAL :: rloop1 - REAL :: rloop2 - REAL :: rstext - REAL(mps) :: secnd - REAL :: rst - REAL :: rstp - REAL, DIMENSION(2) :: ta - INTEGER(mpi) :: i - INTEGER(mpi) :: ii - INTEGER(mpi) :: ix - INTEGER(mpi) :: ixv - INTEGER(mpi) :: iy - INTEGER(mpi) :: k - INTEGER(mpi) :: kfl - INTEGER(mpi) :: lun - INTEGER :: minut - INTEGER :: nhour - INTEGER(mpi) :: nmxy - INTEGER(mpi) :: nrc - INTEGER(mpi) :: nsecnd - INTEGER(mpi) :: ntot - INTEGER(mpi) :: ntsec - - CHARACTER (LEN=24) :: chdate - CHARACTER (LEN=24) :: chost - - INTEGER(mpl) :: rows - INTEGER(mpl) :: cols - - REAL(mpd) :: sums(9) - !$ INTEGER(mpi) :: OMP_GET_NUM_PROCS,OMP_GET_MAX_THREADS - !$ INTEGER(mpi) :: MXTHRD - !$ INTEGER(mpi) :: NPROC - - SAVE - ! ... - CALL etime(ta,rstp) - CALL fdate(chdate) - - ! millepede monitoring file - lunmon=0 - ! millepede.log file - lunlog=8 - lvllog=1 - CALL mvopen(lunlog,'millepede.log') - CALL getenv('HOSTNAME',chost) - IF (chost(1:1) == ' ') CALL getenv('HOST',chost) - WRITE(*,*) '($Rev: 169 $)' - !$ WRITE(*,*) 'using OpenMP (TM)' -#ifdef __GFORTRAN__ - WRITE(*,111) __GNUC__ , __GNUC_MINOR__ , __GNUC_PATCHLEVEL__ -111 FORMAT(' compiled with gcc ',i0,'.',i0,'.',i0) -#endif - WRITE(*,*) ' ' - WRITE(*,*) ' < Millepede II-P starting ... ',chdate - WRITE(*,*) ' ',chost - WRITE(*,*) ' ' - - WRITE(8,*) ' ' - WRITE(8,*) 'Log-file Millepede II-P ', chdate - WRITE(8,*) ' ', chost - CALL peend(-1,'Still running or crashed') - ! read command line and text files - - CALL filetc ! command line and steering file analysis - CALL filetx ! read text files - IF (icheck > 0) THEN - WRITE(*,*) '!!! Checking input only, no calculation of a solution !!!' - WRITE(8,*) '!!! Checking input only, no calculation of a solution !!!' - END IF - lvllog=mprint ! export print level - IF (memdbg > 0) printflagalloc=1 ! debug memory management - !$ WRITE(*,*) - !$ NPROC=1 - !$ MXTHRD=1 - !$ NPROC=OMP_GET_NUM_PROCS() ! number of processors available - !$ CALL OMP_SET_NUM_THREADS(MTHRD) ! set max number of threads to MTHRD - !$ MXTHRD=OMP_GET_MAX_THREADS() ! get max number of threads back - !$ WRITE(*,*) 'Number of processors available: ', NPROC - !$ WRITE(*,*) 'Maximum number of OpenMP threads: ', MXTHRD - !$ WRITE(*,*) 'Number of threads for processing: ', MTHRD - !$ IF (MXREC.GT.0) MTHRDR=1 ! to get allways the same MXREC records - !$ IF (ICHECK.GT.1) MTHRDR=1 ! to get allways the same order of records - !$ WRITE(*,*) 'Number of threads for reading: ', MTHRDR - !$POMP INST INIT ! start profiling with ompP - IF (ncache < 0) THEN - ncache=25000000*mthrd ! default cache size (100 MB per thread) - ENDIF - rows=6; cols=mthrdr - CALL mpalloc(readBufferInfo,rows,cols,'read buffer header') - ! histogram file - lun=7 - CALL mvopen(lun,'millepede.his') - CALL hmplun(lun) ! unit for histograms - CALL gmplun(lun) ! unit for xy data - - ! debugging - IF(nrecpr /= 0.OR.nrecp2 /= 0) THEN - CALL mvopen(1,'mpdebug.txt') - END IF - - CALL etime(ta,rstext) - times(0)=rstext-rstp ! time for text processing - - ! preparation of data sub-arrays - - CALL loop1 - CALL etime(ta,rloop1) - times(1)=rloop1-rstext ! time for LOOP1 - - CALL loop2 - IF(chicut /= 0.0) THEN - WRITE(8,*) 'Chi square cut equiv 3 st.dev applied ...' - WRITE(8,*) ' in first iteration with factor',chicut - WRITE(8,*) ' in second iteration with factor',chirem - WRITE(8,*) ' (reduced by sqrt in next iterations)' - END IF - - IF(lhuber /= 0) THEN - WRITE(8,*) 'Down-weighting of outliers in', lhuber,' iterations' - WRITE(8,*) 'Cut on downweight fraction',dwcut - END IF - - CALL etime(ta,rloop2) - times(2)=rloop2-rloop1 ! time for LOOP2 - - IF(icheck > 0) THEN - CALL prtstat - CALL peend(0,'Ended normally') - GOTO 99 ! only checking input - END IF - - ! use different solution methods - - CALL mstart('Iteration') ! Solution module starting - - CALL xloopn ! all methods - - ! ------------------------------------------------------------------ - - IF(nloopn > 2.AND.nhistp /= 0) THEN ! last iteration - CALL hmprnt(3) ! scaled residual of single measurement (with global deriv.) - CALL hmprnt(12) ! scaled residual of single measurement (no global deriv.) - CALL hmprnt(4) ! chi^2/Ndf - END IF - IF(nloopn > 2) THEN - CALL hmpwrt(3) - CALL hmpwrt(12) - CALL hmpwrt(4) - CALL gmpwrt(4) ! location, dispersion (res.) as a function of record nr - IF (nloopn <= lfitnp) THEN - CALL hmpwrt(13) - CALL hmpwrt(14) - CALL gmpwrt(5) - END IF - END IF - IF(nhistp /= 0) THEN - CALL gmprnt(1) - CALL gmprnt(2) - END IF - CALL gmpwrt(1) ! output of xy data - CALL gmpwrt(2) ! output of xy data - ! 'track quality' per binary file - IF (nfilb > 1) THEN - CALL gmpdef(6,1,'log10(#records) vs file number') - CALL gmpdef(7,1,'final rejection fraction vs file number') - CALL gmpdef(8,1, & - 'final from accepted local fits vs file number') - CALL gmpdef(9,1, ' from accepted local fits vs file number') - - DO i=1,nfilb - kfl=kfd(2,i) - nrc=-kfd(1,i) - IF (nrc > 0) THEN - rej=REAL(nrc-jfd(kfl),mps)/REAL(nrc,mps) - CALL gmpxy(6,REAL(kfl,mps),LOG10(REAL(nrc,mps))) ! log10(#records) vs file - CALL gmpxy(7,REAL(kfl,mps),rej) ! rejection fraction vs file - END IF - IF (jfd(kfl) > 0) THEN - c2ndf=cfd(kfl)/REAL(jfd(kfl),mps) - CALL gmpxy(8,REAL(kfl,mps),c2ndf) ! vs file - andf=REAL(dfd(kfl),mps)/REAL(jfd(kfl),mps) - CALL gmpxy(9,REAL(kfl,mps),andf) ! vs file - END IF - END DO - IF(nhistp /= 0) THEN - CALL gmprnt(6) - CALL gmprnt(7) - CALL gmprnt(8) - CALL gmprnt(9) - END IF - CALL gmpwrt(6) ! output of xy data - CALL gmpwrt(7) ! output of xy data - CALL gmpwrt(8) ! output of xy data - CALL gmpwrt(9) ! output of xy data - END IF - - IF(ictest == 1) THEN - WRITE(*,*) ' ' - WRITE(*,*) 'Misalignment test wire chamber' - WRITE(*,*) ' ' - - CALL hmpdef( 9,-0.0015,+0.0015,'True - fitted displacement') - CALL hmpdef(10,-0.0015,+0.0015,'True - fitted Vdrift') - DO i=1,4 - sums(i)=0.0_mpd - END DO - DO i=1,nplan - diff=REAL(-del(i)-globalParameter(i),mps) - sums(1)=sums(1)+diff - sums(2)=sums(2)+diff*diff - diff=REAL(-dvd(i)-globalParameter(100+i),mps) - sums(3)=sums(3)+diff - sums(4)=sums(4)+diff*diff - END DO - sums(1)=0.01_mpd*sums(1) - sums(2)=SQRT(0.01_mpd*sums(2)) - sums(3)=0.01_mpd*sums(3) - sums(4)=SQRT(0.01_mpd*sums(4)) - WRITE(*,143) 'Parameters 1 - 100: mean =',sums(1), 'rms =',sums(2) - WRITE(*,143) 'Parameters 101 - 200: mean =',sums(3), 'rms =',sums(4) -143 FORMAT(6X,a28,f9.6,3X,a5,f9.6) - WRITE(*,*) ' ' - WRITE(*,*) ' ' - WRITE(*,*) ' I ' - WRITE(*,*) ' --- ' - DO i=1,100 - WRITE(*,102) i,-del(i),globalParameter(i),-del(i)-globalParameter(i), & - -dvd(i),globalParameter(100+i),-dvd(i)-globalParameter(100+i) - diff=REAL(-del(i)-globalParameter(i),mps) - CALL hmpent( 9,diff) - diff=REAL(-dvd(i)-globalParameter(100+i),mps) - CALL hmpent(10,diff) - END DO - IF(nhistp /= 0) THEN - CALL hmprnt( 9) - CALL hmprnt(10) - END IF - CALL hmpwrt( 9) - CALL hmpwrt(10) - END IF - IF(ictest > 1) THEN - WRITE(*,*) ' ' - WRITE(*,*) 'Misalignment test Si tracker' - WRITE(*,*) ' ' - - CALL hmpdef( 9,-0.0025,+0.0025,'True - fitted displacement X') - CALL hmpdef(10,-0.025,+0.025,'True - fitted displacement Y') - DO i=1,9 - sums(i)=0.0_mpd - END DO - nmxy=nmx*nmy - ix=0 - iy=ntot - DO i=1,nlyr - DO k=1,nmxy - ix=ix+1 - diff=REAL(-sdevx((i-1)*nmxy+k)-globalParameter(ix),mps) - sums(1)=sums(1)+1.0_mpd - sums(2)=sums(2)+diff - sums(3)=sums(3)+diff*diff - ixv=globalParLabelIndex(2,ix) - IF (ixv > 0.AND.metsol == 1.OR.metsol == 2) THEN - ii=(ixv*ixv+ixv)/2 - gmati=REAL(globalMatD(ii),mps) - ERR=SQRT(ABS(gmati)) - diff=diff/ERR - sums(7)=sums(7)+1.0_mpd - sums(8)=sums(8)+diff - sums(9)=sums(9)+diff*diff - END IF - END DO - IF (MOD(i,3) == 1) THEN - DO k=1,nmxy - iy=iy+1 - diff=-REAL(sdevy((i-1)*nmxy+k)-globalParameter(iy),mps) - sums(4)=sums(4)+1.0_mpd - sums(5)=sums(5)+diff - sums(6)=sums(6)+diff*diff - ixv=globalParLabelIndex(2,iy) - IF (ixv > 0.AND.metsol == 1.OR.metsol == 2) THEN - ii=(ixv*ixv+ixv)/2 - gmati=REAL(globalMatD(ii),mps) - ERR=SQRT(ABS(gmati)) - diff=diff/ERR - sums(7)=sums(7)+1.0_mpd - sums(8)=sums(8)+diff - sums(9)=sums(9)+diff*diff - END IF - END DO - END IF - END DO - sums(2)=sums(2)/sums(1) - sums(3)=SQRT(sums(3)/sums(1)) - sums(5)=sums(5)/sums(4) - sums(6)=SQRT(sums(6)/sums(4)) - WRITE(*,143) 'Parameters 1 - 500: mean =',sums(2), 'rms =',sums(3) - WRITE(*,143) 'Parameters 501 - 700: mean =',sums(5), 'rms =',sums(6) - IF (sums(7) > 0.5_mpd) THEN - sums(8)=sums(8)/sums(7) - sums(9)=SQRT(sums(9)/sums(7)) - WRITE(*,143) 'Parameter pulls, all: mean =',sums(8), 'rms =',sums(9) - END IF - WRITE(*,*) ' ' - WRITE(*,*) ' ' - WRITE(*,*) ' I ' - WRITE(*,*) ' --- ' - ix=0 - iy=ntot - DO i=1,nlyr - DO k=1,nmxy - ix=ix+1 - diff=REAL(-sdevx((i-1)*nmxy+k)-globalParameter(ix),mps) - CALL hmpent( 9,diff) - WRITE(*,102) ix,-sdevx((i-1)*nmxy+k),globalParameter(ix),-diff - END DO - END DO - DO i=1,nlyr - IF (MOD(i,3) == 1) THEN - DO k=1,nmxy - iy=iy+1 - diff=REAL(-sdevy((i-1)*nmxy+k)-globalParameter(iy),mps) - CALL hmpent(10,diff) - WRITE(*,102) iy,-sdevy((i-1)*nmxy+k),globalParameter(iy),-diff - END DO - END IF - END DO - IF(nhistp /= 0) THEN - CALL hmprnt( 9) - CALL hmprnt(10) - END IF - CALL hmpwrt( 9) - CALL hmpwrt(10) - END IF - - IF(nrec1+nrec2 > 0) THEN - WRITE(8,*) ' ' - IF(nrec1 > 0) THEN - WRITE(8,*) 'Record',nrec1,' has largest residual:',value1 - END IF - IF(nrec2 > 0) THEN - WRITE(8,*) 'Record',nrec2,' has largest Chi^2/Ndf:',value2 - END IF - END IF - IF(nrec3 < huge(nrec3)) THEN - WRITE(8,*) 'Record',nrec3, ' is first with error (rank deficit/NaN)' - END IF -99 WRITE(8,*) ' ' - IF (iteren > mreqenf) THEN - WRITE(8,*) 'In total 3 +',nloopn,' loops through the data files' - ELSE - WRITE(8,*) 'In total 2 +',nloopn,' loops through the data files' - ENDIF - IF (mnrsit > 0) THEN - WRITE(8,*) ' ' - WRITE(8,*) 'In total ',mnrsit,' internal MINRES iterations' - END IF - - WRITE(8,103) times(0),times(1),times(2),times(4),times(7), & - times(5),times(8),times(3),times(6) - - CALL etime(ta,rst) - deltat=rst-rstp - ntsec=nint(deltat,mpi) - CALL sechms(deltat,nhour,minut,secnd) - nsecnd=nint(secnd,mpi) ! round - WRITE(8,*) 'Total time =',ntsec,' seconds =',nhour,' h',minut, & - ' m',nsecnd,' seconds' - CALL fdate(chdate) - WRITE(8,*) 'end ', chdate - gbu=1.0E-9*REAL(maxwordsalloc*(BIT_SIZE(1_mpi)/8),mps) ! GB used - WRITE(8,*) ' ' - WRITE(8,105) gbu - - ! Rejects ---------------------------------------------------------- - - IF(nrejec(0)+nrejec(1)+nrejec(2)+nrejec(3) /= 0) THEN - WRITE(8,*) ' ' - WRITE(8,*) 'Data rejected in last iteration: ' - WRITE(8,*) ' ', & - nrejec(0), ' (rank deficit/NaN) ',nrejec(1),' (Ndf=0) ', & - nrejec(2), ' (huge) ',nrejec(3),' (large)' - WRITE(8,*) ' ' - END IF - IF (icheck <= 0) CALL explfc(8) - - WRITE(*,*) ' ' - WRITE(*,*) ' < Millepede II-P ending ... ', chdate ! with exit code',ITEXIT,' >' - WRITE(*,*) ' ' - gbu=1.0E-9*REAL(maxwordsalloc*(BIT_SIZE(1_mpi)/8),mps) ! GB used - WRITE(*,105) gbu - WRITE(*,*) ' ' - -102 FORMAT(2X,i4,2X,3F10.5,2X,3F10.5) -103 FORMAT(' Times [in sec] for text processing',f12.3/ & - ' LOOP1',f12.3/ & - ' LOOP2',f12.3/ & - ' func. value ',f12.3,' *',f4.0/ & - ' func. value, global matrix, solution',f12.3,' *',f4.0/ & - ' new solution',f12.3,' *',f4.0/) -105 FORMAT(' Peak dynamic memory allocation: ',f11.6,' GB') -END PROGRAM mptwo ! Mille - -!> Error for single global parameter from \ref minresmodule::minres "MINRES". -!! -!! Calculate single row 'x_i' from inverse matrix by solving A*x_i=b -!! with b=0 except b_i=1. -!! -!! \param [in] ivgbi index of variable parameter - -SUBROUTINE solglo(ivgbi) - USE mpmod - USE minresModule, ONLY: minres - - IMPLICIT NONE - REAL(mps) :: par - REAL(mps) :: dpa - REAL(mps) :: err - REAL(mps) :: gcor2 - INTEGER(mpi) :: iph - INTEGER(mpi) :: istop - INTEGER(mpi) :: itgbi - INTEGER(mpi) :: itgbl - INTEGER(mpi) :: itn - INTEGER(mpi) :: itnlim - INTEGER(mpi) :: nout - - INTEGER(mpi), INTENT(IN) :: ivgbi - - REAL(mpd) :: shift - REAL(mpd) :: rtol - REAL(mpd) :: anorm - REAL(mpd) :: acond - REAL(mpd) :: arnorm - REAL(mpd) :: rnorm - REAL(mpd) :: ynorm - REAL(mpd) :: gmati - REAL(mpd) :: diag - INTEGER(mpl) :: ijadd - INTEGER(mpl) :: jk - INTEGER(mpl) :: ii - LOGICAL :: checka - EXTERNAL avprod, mcsolv, mvsolv - SAVE - DATA iph/0/ - ! ... - IF(iph == 0) THEN - iph=1 - WRITE(*,101) - END IF - itgbi=globalParVarToTotal(ivgbi) - itgbl=globalParLabelIndex(1,itgbi) - - globalVector=0.0_mpd ! reset rhs vector IGVEC - globalVector(ivgbi)=1.0_mpd - - ! NOUT =6 - nout =0 - itnlim=200 - shift =0.0_mpd - rtol = mrestl ! from steering - checka=.FALSE. - - - IF(mbandw == 0) THEN ! default preconditioner - CALL minres(nagb, avprod, mcsolv, globalVector, shift, checka ,.TRUE. , & - globalCorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm) - - ELSE IF(mbandw > 0) THEN ! band matrix preconditioner - CALL minres(nagb, avprod, mvsolv, globalVector, shift, checka ,.TRUE. , & - globalCorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm) - ELSE - CALL minres(nagb, avprod, mvsolv, globalVector, shift, checka ,.FALSE. , & - globalCorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm) - END IF - - par=REAL(globalParameter(itgbi),mps) - dpa=REAL(par-globalParStart(itgbi),mps) - gmati=globalCorrections(ivgbi) - ERR=SQRT(ABS(REAL(gmati,mps))) - IF(gmati < 0.0_mpd) ERR=-ERR - IF(matsto == 1) THEN ! normal matrix ! ??? - ii=ivgbi - jk=(ii*ii+ii)/2 - ELSE IF(matsto == 2) THEN ! sparse matrix - jk=ijadd(ivgbi,ivgbi) - END IF - IF (jk > 0) THEN - diag=globalMatD(jk) - ELSE - diag=REAL(globalMatF(-jk),mpd) - END IF - gcor2=REAL(1.0_mpd-1.0_mpd/(gmati*diag),mps) ! global correlation (squared) - WRITE(*,102) itgbl,par,REAL(globalParPreSigma(itgbi),mps),dpa,ERR,gcor2,itn -101 FORMAT(1X,' label parameter presigma differ', & - ' Error gcor^2 iit'/ 1X,'---------',2X,5('-----------'),2X,'----') -102 FORMAT(i10,2X,4G12.4,f7.4,i6,i4) -END SUBROUTINE solglo - -!> Error for single global parameter from \ref minresqlpmodule::minresqlp "MINRES-QLP". -!! -!! Calculate single row 'x_i' from inverse matrix by solving A*x_i=b -!! with b=0 except b_i=1. -!! -!! \param [in] ivgbi index of variable parameter - -SUBROUTINE solgloqlp(ivgbi) - USE mpmod - USE minresqlpModule, ONLY: minresqlp - - IMPLICIT NONE - REAL(mps) :: par - REAL(mps) :: dpa - REAL(mps) :: err - REAL(mps) :: gcor2 - INTEGER(mpi) :: iph - INTEGER(mpi) :: istop - INTEGER(mpi) :: itgbi - INTEGER(mpi) :: itgbl - INTEGER(mpi) :: itn - INTEGER(mpi) :: itnlim - INTEGER(mpi) :: nout - - INTEGER(mpi), INTENT(IN) :: ivgbi - - REAL(mpd) :: shift - REAL(mpd) :: rtol - REAL(mpd) :: mxxnrm - REAL(mpd) :: trcond - REAL(mpd) :: gmati - REAL(mpd) :: diag - INTEGER(mpl) :: ijadd - INTEGER(mpl) :: jk - INTEGER(mpl) :: ii - - EXTERNAL avprod, mcsolv, mvsolv - SAVE - DATA iph/0/ - ! ... - IF(iph == 0) THEN - iph=1 - WRITE(*,101) - END IF - itgbi=globalParVarToTotal(ivgbi) - itgbl=globalParLabelIndex(1,itgbi) - - globalVector=0.0_mpd ! reset rhs vector IGVEC - globalVector(ivgbi)=1.0_mpd - - ! NOUT =6 - nout =0 - itnlim=200 - shift =0.0_mpd - rtol = mrestl ! from steering - mxxnrm = REAL(nagb,mpd)/SQRT(epsilon(mxxnrm)) - IF(mrmode == 1) THEN - trcond = 1.0_mpd/epsilon(trcond) ! only QR - ELSE IF(mrmode == 2) THEN - trcond = 1.0_mpd ! only QLP - ELSE - trcond = mrtcnd ! QR followed by QLP - END IF - - IF(mbandw == 0) THEN ! default preconditioner - CALL minresqlp( n=nagb, Aprod=avprod, b=globalVector, Msolve=mcsolv, nout=nout, & - itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, & - x=globalCorrections, istop=istop, itn=itn) - ELSE IF(mbandw > 0) THEN ! band matrix preconditioner - CALL minresqlp( n=nagb, Aprod=avprod, b=globalVector, Msolve=mvsolv, nout=nout, & - itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, & - x=globalCorrections, istop=istop, itn=itn) - ELSE - CALL minresqlp( n=nagb, Aprod=avprod, b=globalVector, nout=nout, & - itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, & - x=globalCorrections, istop=istop, itn=itn) - END IF - - par=REAL(globalParameter(itgbi),mps) - dpa=REAL(par-globalParStart(itgbi),mps) - gmati=globalCorrections(ivgbi) - ERR=SQRT(ABS(REAL(gmati,mps))) - IF(gmati < 0.0_mpd) ERR=-ERR - IF(matsto == 1) THEN ! normal matrix ! ??? - ii=ivgbi - jk=(ii*ii+ii)/2 - ELSE IF(matsto == 2) THEN ! sparse matrix - jk=ijadd(ivgbi,ivgbi) - END IF - IF (jk > 0) THEN - diag=globalMatD(jk) - ELSE - diag=REAL(globalMatF(-jk),mpd) - END IF - gcor2=REAL(1.0_mpd-1.0_mpd/(gmati*diag),mps) ! global correlation (squared) - WRITE(*,102) itgbl,par,REAL(globalParPreSigma(itgbi),mps),dpa,ERR,gcor2,itn -101 FORMAT(1X,' label parameter presigma differ', & - ' Error gcor^2 iit'/ 1X,'---------',2X,5('-----------'),2X,'----') -102 FORMAT(i10,2X,4G12.4,f7.4,i6,i4) -END SUBROUTINE solgloqlp - -!> Add \ref par-glowithcon "constraint" information to matrix and vector. -SUBROUTINE addcst - USE mpmod - - IMPLICIT NONE - REAL(mpd) :: climit - REAL(mpd) :: factr - REAL(mpd) :: sgm - - INTEGER(mpi) :: i - INTEGER(mpi) :: icgb - INTEGER(mpi) :: irhs - INTEGER(mpi) :: itgbi - INTEGER(mpi) :: ivgb - INTEGER(mpi) :: j - INTEGER(mpi) :: jcgb - INTEGER(mpi) :: l - INTEGER(mpi) :: label - INTEGER(mpi) :: nop - INTEGER(mpi) :: inone - - REAL(mpd) :: rhs - REAL(mpd) :: drhs(4) - INTEGER(mpi) :: idrh (4) - SAVE - ! ... - nop=0 - IF(lenConstraints == 0) RETURN ! no constraints - climit=1.0E-5 ! limit for printout - irhs=0 ! number of values in DRHS(.), to be printed - - DO jcgb=1,ncgb - icgb=matConsSort(3,jcgb) ! unsorted constraint index - i=vecConsStart(icgb) - rhs=listConstraints(i )%value ! right hand side - sgm=listConstraints(i+1)%value ! sigma parameter - DO j=i+2,vecConsStart(icgb+1)-1 - label=listConstraints(j)%label - factr=listConstraints(j)%value - itgbi=inone(label) ! -> ITGBI= index of parameter label - ivgb =globalParLabelIndex(2,itgbi) ! -> variable-parameter index - - IF(icalcm == 1.AND.nagb > nvgb.AND.ivgb > 0) THEN - CALL mupdat(nvgb+jcgb,ivgb,factr) ! add to matrix - END IF - - rhs=rhs-factr*globalParameter(itgbi) ! reduce residuum - END DO - IF(ABS(rhs) > climit) THEN - irhs=irhs+1 - idrh(irhs)=jcgb - drhs(irhs)=rhs - nop=1 - IF(irhs == 4) THEN - WRITE(*,101) (idrh(l),drhs(l),l=1,irhs) - irhs=0 - END IF - END IF - vecConsResiduals(jcgb)=rhs - IF (nagb > nvgb) globalVector(nvgb+jcgb)=rhs - END DO - - IF(irhs /= 0) THEN - WRITE(*,101) (idrh(l),drhs(l),l=1,irhs) - END IF - IF(nop == 0) RETURN - WRITE(*,102) ' Constraints: only equation values >', climit,' are printed' -101 FORMAT(' ',4(i4,g11.3)) -102 FORMAT(a,g11.2,a) -END SUBROUTINE addcst - -!> Prepare constraints. -!! -!! Count, sort constraints and split into disjoint blocks. - -SUBROUTINE prpcon - USE mpmod - USE mpdalc - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: icgb - INTEGER(mpi) :: isblck - INTEGER(mpi) :: ilast - INTEGER(mpi) :: itgbi - INTEGER(mpi) :: ivgb - INTEGER(mpi) :: jcgb - INTEGER(mpi) :: label - INTEGER(mpi) :: labelf - INTEGER(mpi) :: labell - INTEGER(mpi) :: ncon - INTEGER(mpi) :: npar - INTEGER(mpi) :: nconmx - INTEGER(mpi) :: nparmx - INTEGER(mpi) :: inone - INTEGER(mpi) :: itype - INTEGER(mpi) :: ncgbw - INTEGER(mpi) :: newlen - INTEGER(mpi) :: nvar - INTEGER(mpi) :: last - INTEGER(mpi) :: lastlen - - INTEGER(mpl):: length - INTEGER(mpl) :: rows - - ncgb=0 - ncgbw=0 - ncgbe=0 - IF(lenConstraints == 0) RETURN ! no constraints - - newlen=0 - lastlen=0 - nvar=-1 - i=0 - last=-1 - itype=0 - ! find next constraint header and count nr of constraints - DO WHILE(i < lenConstraints) - i=i+1 - label=listConstraints(i)%label - IF(last == 0.AND.label < 0) THEN - IF (ncgb > 0 .AND. icheck>0) WRITE(*,113) ncgb, newlen-lastlen-3, nvar - IF (nvar == 0) ncgbe=ncgbe+1 - IF (nvar == 0 .AND. iskpec > 0) THEN - ! overwrite - newlen=lastlen - ! copy previous value (for label 0) - newlen=newlen+1 - listConstraints(newlen)%value=listConstraints(i-1)%value - ELSE - lastlen=newlen-1 ! end of last accepted constraint - END IF - ncgb=ncgb+1 - itype=-label - IF(itype == 2) ncgbw=ncgbw+1 - nvar=0 - END IF - last=label - IF(label > 0) THEN - itgbi=inone(label) ! -> ITGBI= index of parameter label - ivgb =globalParLabelIndex(2,itgbi) ! -> variable-parameter index - IF (ivgb > 0) nvar=nvar+1 - END IF - IF(label > 0.AND.itype == 2) THEN ! weighted constraints - itgbi=inone(label) ! -> ITGBI= index of parameter label - listConstraints(i)%value=listConstraints(i)%value*globalParCounts(itgbi) - END IF - newlen=newlen+1 - listConstraints(newlen)%label=listConstraints(i)%label ! copy label - listConstraints(newlen)%value=listConstraints(i)%value ! copy value - END DO - IF (ncgb > 0 .AND. icheck>0) WRITE(*,113) ncgb, newlen-lastlen-2, nvar - IF (nvar == 0) ncgbe=ncgbe+1 - IF (nvar == 0 .AND. iskpec > 0) newlen=lastlen - lenConstraints=newlen - - IF (ncgbe > 0 .AND. iskpec > 0) THEN - WRITE(*,*) 'PRPCON:',ncgbe,' empty constraints skipped' - ncgb=ncgb-ncgbe - END IF - IF (ncgbw == 0) THEN - WRITE(*,*) 'PRPCON:',ncgb,' constraints accepted' - ELSE - WRITE(*,*) 'PRPCON:',ncgb,' constraints accepted,',ncgbw, 'weighted' - END IF - WRITE(*,*) - - IF(lenConstraints == 0) RETURN ! no constraints left - - ! keys and index for sorting of constraints - length=ncgb+1; rows=3 - CALL mpalloc(matConsSort,rows,length,'keys and index for sorting (I)') - matConsSort(1,ncgb+1)=ntgb+1 - ! start of constraint in list - CALL mpalloc(vecConsStart,length,'start of constraint in list (I)') - vecConsStart(ncgb+1)=lenConstraints+1 - ! start and parameter range of constraint blocks - CALL mpalloc(matConsBlocks,rows,length,'start of constraint blocks, par. range (I)') - - ! prepare - i=1 - DO icgb=1,ncgb - ! new constraint - vecConsStart(icgb)=i - matConsSort(1,icgb)=ntgb ! min variable parameter - matConsSort(2,icgb)=0 ! max variable parameter - matConsSort(3,icgb)=icgb ! index - i=i+2 - DO - label=listConstraints(i)%label - itgbi=inone(label) ! -> ITGBI= index of parameter label - ivgb =globalParLabelIndex(2,itgbi) ! -> variable-parameter index - IF(ivgb > 0) THEN - matConsSort(1,icgb)=min(matConsSort(1,icgb),ivgb) - matConsSort(2,icgb)=max(matConsSort(2,icgb),ivgb) - END IF - i=i+1 - IF(i > lenConstraints) EXIT - IF(listConstraints(i)%label == 0) EXIT - END DO - END DO - - ! sort constraints - call sort2i(matConsSort,ncgb) - - ! loop over sorted constraints, try to split into blocks - ncblck=0 - nconmx=0 - nparmx=0 - mszcon=0 - mszprd=0 - isblck=1 - ilast=0 - DO jcgb=1,ncgb - ! index in list - icgb=matConsSort(3,jcgb) - ! split into disjoint blocks - ilast=max(ilast, matConsSort(2,jcgb)) - IF (icheck > 1) THEN - labelf=globalParLabelIndex(1,globalParVarToTotal(matConsSort(1,jcgb))) - labell=globalParLabelIndex(1,globalParVarToTotal(matConsSort(2,jcgb))) - WRITE(*,*) ' Cons. sorted', jcgb, icgb, vecConsStart(icgb), labelf, labell - END IF - IF (matConsSort(1,jcgb+1) > ilast) THEN - ncblck=ncblck+1 - matConsBlocks(1,ncblck)=isblck - matConsBlocks(2,ncblck)=matConsSort(1,isblck) ! save first parameter in block - matConsBlocks(3,ncblck)=ilast ! save last parameter in block - ncon=jcgb+1-isblck - npar=ilast+1-matConsSort(1,isblck) - nconmx=max(nconmx,ncon) - nparmx=max(nparmx,npar) - mszcon=mszcon+ncon*npar ! (sum of) block size for constraint matrix - mszprd=mszprd+(ncon*ncon+ncon)/2 ! (sum of) block size for product matrix - IF (icheck > 0) THEN - labelf=globalParLabelIndex(1,globalParVarToTotal(matConsSort(1,isblck))) - labell=globalParLabelIndex(1,globalParVarToTotal(ilast)) - WRITE(*,*) ' Cons. block ', ncblck, isblck, jcgb, labelf, labell - ENDIF - ! reset for new block - isblck=jcgb+1 - END IF - END DO - matConsBlocks(1,ncblck+1)=ncgb+1 - - IF (ncblck+icheck > 1) THEN - WRITE(*,*) - WRITE(*,*) 'PRPCON: constraints split into ', ncblck, '(disjoint) blocks' - WRITE(*,*) ' max block size (cons., par.) ', nconmx, nparmx - IF (icheck > 0) WRITE(*,*) ' total block matrix sizes ', mszcon, mszprd - END IF -113 FORMAT(' constraint',i6,' : ',i9,' parameters,',i9,' variable') - -END SUBROUTINE prpcon - -!> Matrix for feasible solution. -!! -!! Check rank of product matrix of constraints. - -SUBROUTINE feasma - USE mpmod - USE mpdalc - - IMPLICIT NONE - REAL(mpd) :: factr - REAL(mpd) :: sgm - INTEGER(mpi) :: i - INTEGER(mpi) :: iblck - INTEGER(mpi) :: icgb - INTEGER(mpi) :: ij - INTEGER(mpi) :: ifirst - INTEGER(mpi) :: ilast - INTEGER(mpi) :: ioffc - INTEGER(mpi) :: ioffp - INTEGER(mpi) :: irank - INTEGER(mpi) :: ipar0 - INTEGER(mpi) :: itgbi - INTEGER(mpi) :: ivgb - INTEGER(mpi) :: j - INTEGER(mpi) :: jcgb - INTEGER(mpi) :: l - INTEGER(mpi) :: label - INTEGER(mpi) :: ncon - INTEGER(mpi) :: npar - INTEGER(mpi) :: nrank - INTEGER(mpi) :: inone - - REAL(mpd):: rhs - REAL(mpd):: evmax - REAL(mpd):: evmin - INTEGER(mpl):: length - REAL(mpd), DIMENSION(:), ALLOCATABLE :: matConstraintsT - REAL(mpd), DIMENSION(:), ALLOCATABLE :: auxVectorD - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: auxVectorI - SAVE - ! ... - - IF(ncgb == 0) RETURN ! no constraints - - ! QL decomposition - IF (nfgb < nvgb) CALL qlini(nvgb,ncgb) - ! product matrix A A^T (A is stored as transposed) - length=mszprd - CALL mpalloc(matConsProduct, length, 'product matrix of constraints (blocks)') - matConsProduct=0.0_mpd - length=ncgb - CALL mpalloc(vecConsResiduals, length, 'residuals of constraints') - CALL mpalloc(vecConsSolution, length, 'solution for constraints') - CALL mpalloc(auxVectorI,length,'auxiliary array (I)') ! int aux 1 - CALL mpalloc(auxVectorD,length,'auxiliary array (D)') ! double aux 1 - ! constraint matrix A (A is stored as transposed) - length = mszcon - CALL mpalloc(matConstraintsT,length,'transposed matrix of constraints (blocks)') - matConstraintsT=0.0_mpd - - ! loop over sorted constraints, fill matrices, get rank, inverted product matrix (in blocks) - ioffc=0 ! block offset in constraint matrix - ioffp=0 ! block offset in product matrix - nrank=0 - DO iblck=1,ncblck - ifirst=matConsBlocks(1,iblck) ! first constraint in block - ilast=matConsBlocks(1,iblck+1)-1 ! last constraint in block - ncon=ilast+1-ifirst - ipar0=matConsBlocks(2,iblck)-1 ! parameter offset - npar=matConsBlocks(3,iblck)-ipar0 ! number of parameters - DO jcgb=ifirst,ilast - ! index in list - icgb=matConsSort(3,jcgb) - ! fill constraint matrix - i=vecConsStart(icgb) - rhs=listConstraints(i )%value ! right hand side - sgm=listConstraints(i+1)%value ! sigma parameter - DO j=i+2,vecConsStart(icgb+1)-1 - label=listConstraints(j)%label - factr=listConstraints(j)%value - itgbi=inone(label) ! -> ITGBI= index of parameter label - ivgb =globalParLabelIndex(2,itgbi) ! -> variable-parameter index - IF(ivgb > 0) matConstraintsT(ivgb-ipar0+ioffc+(jcgb-ifirst)*npar)=factr ! matrix element - globalParCons(itgbi)=globalParCons(itgbi)+1 - rhs=rhs-factr*globalParameter(itgbi) ! reduce residuum - END DO - vecConsResiduals(jcgb)=rhs ! constraint discrepancy - END DO - - ! get rank of blocks - DO l=ioffc+1,ioffc+npar - ij=ioffp - DO i=1,ncon - DO j=1,i - ij=ij+1 - matConsProduct(ij)=matConsProduct(ij)+matConstraintsT((i-1)*npar+l)*matConstraintsT((j-1)*npar+l) - END DO - END DO - END DO - ! inversion of product matrix of constraints - CALL sqminv(matConsProduct(ioffp+1:ij),vecConsResiduals(ifirst:ilast),ncon,irank, auxVectorD, auxVectorI) - IF (icheck > 1) WRITE(*,*) ' Constraint block rank', iblck, ncon, irank - nrank=nrank+irank - ioffc=ioffc+npar*ncon - ioffp=ij - END DO - - nmiss1=ncgb-nrank - - WRITE(*,*) ' ' - WRITE(*,*) 'Rank of product matrix of constraints is',nrank, & - ' for',ncgb,' constraint equations' - WRITE(8,*) 'Rank of product matrix of constraints is',nrank, & - ' for',ncgb,' constraint equations' - IF(nrank < ncgb) THEN - WRITE(*,*) 'Warning: insufficient constraint equations!' - WRITE(8,*) 'Warning: insufficient constraint equations!' - IF (iforce == 0) THEN - isubit=1 - WRITE(*,*) ' --> enforcing SUBITO mode' - WRITE(8,*) ' --> enforcing SUBITO mode' - END IF - END IF - - ! QL decomposition - IF (nfgb < nvgb) THEN - print * - print *, 'QL decomposition of constraints matrix' - CALL qldecb(matConstraintsT,ncblck,matConsBlocks) - ! check eignevalues of L - CALL qlgete(evmin,evmax) - PRINT *, ' largest |eigenvalue| of L: ', evmax - PRINT *, ' smallest |eigenvalue| of L: ', evmin - IF (evmin == 0.0_mpd) THEN - CALL peend(27,'Aborted, singular QL decomposition of constraints matrix') - STOP 'FEASMA: stopping due to singular QL decomposition of constraints matrix' - END IF - END IF - - CALL mpdealloc(matConstraintsT) - CALL mpdealloc(auxVectorD) - CALL mpdealloc(auxVectorI) - - RETURN -END SUBROUTINE feasma ! matrix for feasible solution - -!> Make parameters feasible. -!! -!! \ref sssec-feas "Correct" for constraint equation discrepancies. -!! -!! \param [in] concut cut for discrepancies -!! \param [out] iact =1 if correction needed, else =0 -!! -SUBROUTINE feasib(concut,iact) - USE mpmod - USE mpdalc - - IMPLICIT NONE - REAL(mpd) :: factr - REAL(mpd) :: sgm - INTEGER(mpi) :: i - INTEGER(mpi) :: icgb - INTEGER(mpi) :: iter - INTEGER(mpi) :: itgbi - INTEGER(mpi) :: ivgb - INTEGER(mpi) :: iblck - INTEGER(mpi) :: ieblck - INTEGER(mpi) :: isblck - INTEGER(mpi) :: ifirst - INTEGER(mpi) :: ilast - INTEGER(mpi) :: j - INTEGER(mpi) :: jcgb - INTEGER(mpi) :: label - INTEGER(mpi) :: inone - INTEGER(mpi) :: ncon - - REAL(mps), INTENT(IN) :: concut - INTEGER(mpi), INTENT(OUT) :: iact - - REAL(mpd) :: rhs - REAL(mpd) ::sum1 - REAL(mpd) ::sum2 - REAL(mpd) ::sum3 - - REAL(mpd), DIMENSION(:), ALLOCATABLE :: vecCorrections - SAVE - - iact=0 - IF(lenConstraints == 0) RETURN ! no constraints - - DO iter=1,2 - vecConsResiduals=0.0_mpd - - ! calculate right constraint equation discrepancies - DO jcgb=1,ncgb - icgb=matConsSort(3,jcgb) ! unsorted constraint index - i=vecConsStart(icgb) - rhs=listConstraints(i )%value ! right hand side - sgm=listConstraints(i+1)%value ! sigma parameter - DO j=i+2,vecConsStart(icgb+1)-1 - label=listConstraints(j)%label - factr=listConstraints(j)%value - itgbi=inone(label) ! -> ITGBI= index of parameter label - rhs=rhs-factr*globalParameter(itgbi) ! reduce residuum - ENDDO - vecConsResiduals(jcgb)=rhs ! constraint discrepancy - END DO - - ! constraint equation discrepancies ------------------------------- - - sum1=0.0_mpd - sum2=0.0_mpd - sum3=0.0_mpd - DO icgb=1,ncgb - sum1=sum1+vecConsResiduals(icgb)**2 - sum2=sum2+ABS(vecConsResiduals(icgb)) - sum3=MAX(sum3,ABS(vecConsResiduals(icgb))) - END DO - sum1=SQRT(sum1/REAL(ncgb,mpd)) - sum2=sum2/REAL(ncgb,mpd) - - IF(iter == 1.AND.sum1 < concut) RETURN ! do nothing if correction small - - IF(iter == 1.AND.ncgb <= 12) THEN - WRITE(*,*) ' ' - WRITE(*,*) 'Constraint equation discrepancies:' - WRITE(*,101) (icgb,vecConsResiduals(icgb),icgb=1,ncgb) -101 FORMAT(4X,4(i5,g12.4)) - WRITE(*,103) concut -103 FORMAT(10X,' Cut on rms value is',g8.1) - END IF - - IF(iact == 0) THEN - WRITE(*,*) ' ' - WRITE(*,*) 'Improve constraints' - END IF - iact=1 - - WRITE(*,102) iter,sum1,sum2,sum3 -102 FORMAT(i6,' rms',g12.4,' avrg_abs',g12.4,' max_abs',g12.4) - - CALL mpalloc(vecCorrections,INT(nvgb,mpl),'constraint corrections') - vecCorrections=0.0_mpd - - ! multiply (block-wise) inverse matrix and constraint vector - isblck=0 - DO iblck=1,ncblck - ifirst=matConsBlocks(1,iblck) ! first constraint in block - ilast=matConsBlocks(1,iblck+1)-1 ! last constraint in block - ncon=ilast+1-ifirst - ieblck=isblck+(ncon*(ncon+1))/2 - CALL dbsvx(matConsProduct(isblck+1:ieblck),vecConsResiduals(ifirst:ilast),vecConsSolution(ifirst:ilast),ncon) - isblck=ieblck - END DO - - DO jcgb=1,ncgb - icgb=matConsSort(3,jcgb) ! unsorted constraint index - i=vecConsStart(icgb) - rhs=listConstraints(i )%value ! right hand side - sgm=listConstraints(i+1)%value ! sigma parameter - DO j=i+2,vecConsStart(icgb+1)-1 - label=listConstraints(j)%label - factr=listConstraints(j)%value - itgbi=inone(label) ! -> ITGBI= index of parameter label - ivgb =globalParLabelIndex(2,itgbi) ! -> variable-parameter index - IF(ivgb > 0) THEN - vecCorrections(ivgb)=vecCorrections(ivgb)+vecConsSolution(jcgb)*factr - END IF - ENDDO - END DO - - DO i=1,nvgb ! add corrections - itgbi=globalParVarToTotal(i) - globalParameter(itgbi)=globalParameter(itgbi)+vecCorrections(i) - END DO - - CALL mpdealloc(vecCorrections) - - END DO ! iteration 1 and 2 - -END SUBROUTINE feasib ! make parameters feasible - -!> Read (block of) records from binary files. -!! -!! Optionally using several threads (each file read by single thread). -!! Records larger than the read buffer (ndimbuf) are skipped. -!! In case of skipped events in the first loop over all binary files -!! the buffer size is adapted to the maximum record size (and the initial loop -!! (LOOP1) is repeated). C binary files are handled -!! by \ref readc.c and may be gzipped. -!! -!! \param [out] more more records to come -!! -!! The records consist of parallel integer and real arrays: -!! -!! real array integer array -!! 1 0.0 error count (this record) -!! 2 RMEAS, measured value 0 JA -!! 3 local derivative index of local derivative -!! 4 local derivative index of local derivative -!! 5 ... -!! 6 SIGMA, error (>0) 0 JB -!! global derivative label of global derivative -!! global derivative label of global derivative IST -!! RMEAS, measured value 0 -!! local derivative index of local derivative -!! local derivative index of local derivative -!! ... -!! SIGMA, error 0 -!! global derivative label of global derivative -!! global derivative label of global derivative -!! ... -!! NR global derivative label of global derivative -!! -SUBROUTINE peread(more) - USE mpmod - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: iact - INTEGER(mpi) :: ierrc - INTEGER(mpi) :: ierrf - INTEGER(mpi) :: inder - INTEGER(mpi) :: ioffp - INTEGER(mpi) :: ios - INTEGER(mpi) :: ithr - INTEGER(mpi) :: jfile - INTEGER(mpi) :: jrec - INTEGER(mpi) :: k - INTEGER(mpi) :: kfile - INTEGER(mpi) :: l - INTEGER(mpi) :: lun - INTEGER(mpi) :: mpri - INTEGER(mpi) :: n - INTEGER(mpi) :: nact - INTEGER(mpi) :: nbuf - INTEGER(mpi) :: ndata - INTEGER(mpi) :: noff - INTEGER(mpi) :: noffs - INTEGER(mpi) :: npointer - INTEGER(mpi) :: npri - INTEGER(mpi) :: nr - INTEGER(mpi) :: nrc - INTEGER(mpi) :: nrd - INTEGER(mpi) :: nrpr - INTEGER(mpi) :: nthr - INTEGER(mpi) :: ntot - INTEGER(mpi) :: maxRecordSize - INTEGER(mpi) :: maxRecordFile - - INTEGER(mpi), INTENT(OUT) :: more - - LOGICAL :: lprint - LOGICAL :: floop - LOGICAL :: eof - REAL(mpd) :: ds0 - REAL(mpd) :: ds1 - REAL(mpd) :: ds2 - REAL(mpd) :: dw - !$ INTEGER(mpi) :: OMP_GET_THREAD_NUM - CHARACTER (LEN=7) :: cfile - SAVE - - inder(i)=readBufferDataI(i) - - DATA lprint/.TRUE./ - DATA floop/.TRUE./ - DATA npri / 0 /, mpri / 1000 / - ! ... - IF(ifile == 0) THEN ! start/restart - nrec=0 - nrecd=0 - ntot=0 - sumRecords=0 - skippedRecords=0 - numBlocks=0 - minRecordsInBlock=size(readBufferDataI) - maxRecordsInBlock=0 - readBufferInfo=0 ! reset management info - nrpr=1 - nthr=mthrdr - nact=0 ! active threads (have something still to read) - DO k=1,nthr - IF (ifile < nfilb) THEN - ifile=ifile+1 - readBufferInfo(1,k)=ifile - readBufferInfo(2,k)=nact - nact=nact+1 - END IF - END DO - END IF - nPointer=size(readBufferPointer)/nact - nData=size(readBufferDataI)/nact - more=-1 - DO k=1,nthr - iact=readBufferInfo(2,k) - readBufferInfo(4,k)=0 ! reset counter - readBufferInfo(5,k)=iact*nData ! reset offset - END DO - numBlocks=numBlocks+1 ! new block - - !$OMP PARALLEL & - !$OMP DEFAULT(PRIVATE) & - !$OMP SHARED(readBufferInfo,readBufferPointer,readBufferDataI,readBufferDataD, & - !$OMP readBufferDataF,nPointer,nData,skippedRecords,ndimbuf,NTHR,NFILF,FLOOP, & - !$OMP IFD,KFD,IFILE,NFILB,WFD,XFD,icheck,keepOpen) & - !$OMP NUM_THREADS(NTHR) - - ithr=1 - !$ ITHR=OMP_GET_THREAD_NUM()+1 ! thread number - jfile=readBufferInfo(1,ithr) ! file index - iact =readBufferInfo(2,ithr) ! active thread number - jrec =readBufferInfo(3,ithr) ! records read - ioffp=iact*nPointer - noffs=(ithr-1)*ndimbuf ! offset for intermediate float buffer - - files: DO WHILE (jfile > 0) - kfile=kfd(2,jfile) - ! open again - IF (keepOpen < 1 .AND. readBufferInfo(3,ithr) == 0) THEN - CALL binopn(kfile,ithr,ios) - END IF - records: DO - nbuf=readBufferInfo(4,ithr)+1 - noff=readBufferInfo(5,ithr)+2 ! 2 header words per record - nr=ndimbuf - IF(kfile <= nfilf) THEN ! Fortran file - lun=kfile+10 - READ(lun,IOSTAT=ierrf) n,(readBufferDataF(noffs+i),i=1,min(n/2,nr)),& - (readBufferDataI(noff+i),i=1,min(n/2,nr)) - nr=n/2 - ! convert to double - DO i=1,nr - readBufferDataD(noff+i)=REAL(readBufferDataF(noffs+i),mpr8) - END DO - ! IF (ierrf < 0) REWIND lun ! end-of-file ! CHK use binrwd() - eof=(ierrf /= 0) - ELSE ! C file - lun=kfile-nfilf - IF (keepOpen < 1) lun=ithr -#ifdef READ_C_FILES - CALL readc(readBufferDataD(noff+1),readBufferDataF(noffs+1),readBufferDataI(noff+1),nr,lun,ierrc) - n=nr+nr - IF (ierrc > 4) readBufferInfo(6,ithr)=readBufferInfo(6,ithr)+1 -#else - ierrc=0 -#endif - eof=(ierrc <= 0.AND.ierrc /= -4) ! allow buffer overruns -> skip record - IF(eof.AND.ierrc < 0) THEN - WRITE(*,*) 'Read error for binary Cfile', kfile, 'record', jrec+1, ':', ierrc - WRITE(8,*) 'Read error for binary Cfile', kfile, 'record', jrec+1, ':', ierrc - IF (icheck <= 0) THEN ! stop unless 'checkinput' mode - WRITE(cfile,'(I7)') kfile - CALL peend(18,'Aborted, read error(s) for binary file ' // cfile) - STOP 'PEREAD: stopping due to read errors' - ENDIF - END IF - END IF - IF(eof) EXIT records ! end-of-files or error - - jrec=jrec+1 - readBufferInfo(3,ithr)=jrec - IF(floop) THEN - xfd(jfile)=max(xfd(jfile),n) - IF(ithr == 1) THEN - CALL hmplnt(1,n) - IF(inder(noff+1) /= 0) CALL hmpent(8,REAL(inder(noff+1),mps)) - END IF - END IF - - IF (nr <= ndimbuf) THEN - readBufferInfo(4,ithr)=nbuf - readBufferInfo(5,ithr)=noff+nr - - readBufferPointer(ioffp+nbuf)=noff ! pointer to start of buffer - readBufferDataI(noff )=noff+nr ! pointer to end of buffer - readBufferDataI(noff-1)=ifd(kfile)+jrec ! global record number (available with LOOP2) - readBufferDataD(noff )=REAL(kfile,mpr8) ! file number - readBufferDataD(noff-1)=REAL(wfd(kfile),mpr8) ! weight - - IF ((noff+nr+2+ndimbuf >= nData*(iact+1)).OR.(nbuf >= nPointer)) EXIT files ! buffer full - ELSE - !$OMP ATOMIC - skippedRecords=skippedRecords+1 - CYCLE records - END IF - - END DO records - - readBufferInfo(1,ithr)=-jfile ! flag eof - IF (keepOpen < 1) THEN ! close again - CALL bincls(kfile,ithr) - ELSE ! rewind - CALL binrwd(kfile) - END IF - IF (kfd(1,jfile) == 1) THEN - PRINT *, 'PEREAD: file ', kfile, 'read the first time, found',jrec,' records' - kfd(1,jfile)=-jrec - END IF - ! take next file - !$OMP CRITICAL - IF (ifile < nfilb) THEN - ifile=ifile+1 - jrec=0 - readBufferInfo(1,ithr)=ifile - readBufferInfo(3,ithr)=jrec - END IF - !$OMP END CRITICAL - jfile=readBufferInfo(1,ithr) - - END DO files - !$OMP END PARALLEL - ! compress pointers - nrd=readBufferInfo(4,1) ! buffers from 1 .thread - DO k=2,nthr - iact =readBufferInfo(2,k) - ioffp=iact*nPointer - nbuf=readBufferInfo(4,k) - DO l=1,nbuf - readBufferPointer(nrd+l)=readBufferPointer(ioffp+l) - END DO - nrd=nrd+nbuf - END DO - - more=0 - DO k=1,nthr - jfile=readBufferInfo(1,k) - IF (jfile > 0) THEN ! no eof yet - readBufferInfo(2,k)=more - more=more+1 - ELSE - ! no more files, thread retires - readBufferInfo(1,k)=0 - readBufferInfo(2,k)=-1 - readBufferInfo(3,k)=0 - nrecd=nrecd+readBufferInfo(6,k) - readBufferInfo(6,k)=0 - END IF - END DO - ! record limit ? - IF (mxrec > 0.AND.(ntot+nrd) >= mxrec) THEN - nrd=mxrec-ntot - more=-1 - DO k=1,nthr - jfile=readBufferInfo(1,k) - IF (jfile > 0) THEN ! rewind or close files - nrc=readBufferInfo(3,k) - IF (kfd(1,jfile) == 1) kfd(1,jfile)=-nrc - kfile=kfd(2,jfile) - IF (keepOpen < 1) THEN ! close again - CALL bincls(kfile,k) - ELSE ! rewind - CALL binrwd(kfile) - END IF - END IF - END DO - END IF - - ntot=ntot+nrd - nrec=ntot - numReadbuffer=nrd - - sumRecords=sumRecords+nrd - minRecordsInBlock=MIN(minRecordsInBlock,nrd) - maxRecordsInBlock=MAX(maxRecordsInBlock,nrd) - - DO WHILE (nloopn == 0.AND.ntot >= nrpr) - WRITE(*,*) ' Record ',nrpr - IF (nrpr < 100000) THEN - nrpr=nrpr*10 - ELSE - nrpr=nrpr+100000 - END IF - END DO - - IF (ncache > 0.AND.nloopn <= 1.AND. npri < mpri.AND.mprint > 1) THEN - npri=npri+1 - IF (npri == 1) WRITE(*,100) - WRITE(*,101) nrec, nrd, more ,ifile -100 FORMAT(/' PeRead records active file' & - /' total block threads number') -101 FORMAT(' PeRead',4I10) - END IF - - IF (more <= 0) THEN - ifile=0 - IF (floop) THEN - ! check for file weights - ds0=0.0_mpd - ds1=0.0_mpd - ds2=0.0_mpd - maxRecordSize=0 - maxRecordFile=0 - DO k=1,nfilb - IF (xfd(k) > maxRecordSize) THEN - maxRecordSize=xfd(k) - maxRecordFile=k - END IF - dw=REAL(-kfd(1,k),mpd) - IF (wfd(k) /= 1.0) nfilw=nfilw+1 - ds0=ds0+dw - ds1=ds1+dw*REAL(wfd(k),mpd) - ds2=ds2+dw*REAL(wfd(k)**2,mpd) - END DO - PRINT *, 'PEREAD: file ', maxRecordFile, 'with max record size ', maxRecordSize - IF (nfilw > 0.AND.ds0 > 0.0_mpd) THEN - ds1=ds1/ds0 - ds2=ds2/ds0-ds1*ds1 - DO lun=6,lunlog,2 - WRITE(lun,177) nfilw,REAL(ds1,mps),REAL(ds2,mps) -177 FORMAT(/' !!!!!',i4,' weighted binary files', & - /' !!!!! mean, variance of weights =',2G12.4) - END DO - END IF - ! integrate record numbers - DO k=2,nfilb - ifd(k)=ifd(k-1)-kfd(1,k-1) - END DO - ! sort - IF (nthr > 1) CALL sort2k(kfd,nfilb) - IF (skippedRecords > 0) THEN - PRINT *, 'PEREAD skipped records: ', skippedRecords - ndimbuf=maxRecordSize/2 ! adjust buffer size - END IF - END IF - lprint=.FALSE. - floop=.FALSE. - IF (ncache > 0.AND.nloopn <= 1.AND.mprint > 0) & - WRITE(*,179) numBlocks, sumRecords, minRecordsInBlock, maxRecordsInBlock -179 FORMAT(/' Read cache usage (#blocks, #records, ', & - 'min,max records/block'/17X,4I10) - END IF - RETURN - -END SUBROUTINE peread - -!> Prepare records. -!! -!! For global parameters replace label by index (INONE). -!! -!! \param[in] mode <=0: build index table (INONE) for global variables; \n -!! >0: use index table, can be parallelized, optional scale errors -!! -SUBROUTINE peprep(mode) - USE mpmod - - IMPLICIT NONE - - INTEGER(mpi), INTENT(IN) :: mode - - INTEGER(mpi) :: ibuf - INTEGER(mpi) :: ichunk - INTEGER(mpi) :: iproc - INTEGER(mpi) :: isfrst - INTEGER(mpi) :: islast - INTEGER(mpi) :: ist - INTEGER(mpi) :: j - INTEGER(mpi) :: ja - INTEGER(mpi) :: jb - INTEGER(mpi) :: jsp - INTEGER(mpi) :: nst - INTEGER(mpi), PARAMETER :: maxbad = 100 ! max number of bad records with print out - INTEGER(mpi) :: nbad - INTEGER(mpi) :: nerr - INTEGER(mpi) :: inone - !$ INTEGER(mpi) :: OMP_GET_THREAD_NUM - - - isfrst(ibuf)=readBufferPointer(ibuf)+1 - islast(ibuf)=readBufferDataI(readBufferPointer(ibuf)) - - IF (mode > 0) THEN - ichunk=MIN((numReadBuffer+mthrd-1)/mthrd/32+1,256) - ! parallelize record loop - !$OMP PARALLEL DO & - !$OMP DEFAULT(PRIVATE) & - !$OMP SHARED(numReadBuffer,readBufferPointer,readBufferDataI,readBufferDataD,ICHUNK,iscerr,dscerr) & - !$OMP SCHEDULE(DYNAMIC,ICHUNK) - DO ibuf=1,numReadBuffer ! buffer for current record - iproc=0 - !$ IPROC=OMP_GET_THREAD_NUM() ! thread number - ist=isfrst(ibuf) - nst=islast(ibuf) - DO ! loop over measurements - CALL isjajb(nst,ist,ja,jb,jsp) - IF(jb == 0) EXIT - DO j=1,ist-jb - readBufferDataI(jb+j)=inone( readBufferDataI(jb+j) ) ! translate to index - END DO - ! scale error ? - IF (iscerr > 0) THEN - IF (jb < ist) THEN - readBufferDataD(jb) = readBufferDataD(jb) * dscerr(1) ! 'global' measurement - ELSE - readBufferDataD(jb) = readBufferDataD(jb) * dscerr(2) ! 'local' measurement - END IF - END IF - END DO - END DO - !$OMP END PARALLEL DO - END IF - - !$POMP INST BEGIN(peprep) - IF (mode <= 0) THEN - nbad=0 - DO ibuf=1,numReadBuffer ! buffer for current record - CALL pechk(ibuf,nerr) - IF(nerr > 0) THEN - nbad=nbad+1 - IF(nbad >= maxbad) EXIT - ELSE - ist=isfrst(ibuf) - nst=islast(ibuf) - DO ! loop over measurements - CALL isjajb(nst,ist,ja,jb,jsp) - IF(jb == 0) EXIT - DO j=1,ist-jb - readBufferDataI(jb+j)=inone( readBufferDataI(jb+j) ) ! translate to index - END DO - END DO - END IF - END DO - IF(nbad > 0) THEN - CALL peend(20,'Aborted, bad binary records') - STOP 'PEREAD: stopping due to bad records' - END IF - END IF - !$POMP INST END(peprep) - -END SUBROUTINE peprep - -!> Check Millepede record. -!! -!! Check integer structure of labels and markers (zeros). Check floats for NaNs. -!! -!! \param [in] ibuf buffer number -!! \param [out] nerr error flags -!! -SUBROUTINE pechk(ibuf, nerr) - USE mpmod - - IMPLICIT NONE - REAL(mpr8) :: glder - INTEGER(mpi) :: i - INTEGER(mpi) :: is - INTEGER(mpi) :: ist - INTEGER(mpi) :: inder - INTEGER(mpi) :: ioff - INTEGER(mpi) :: isfrst - INTEGER(mpi) :: islast - INTEGER(mpi) :: ja - INTEGER(mpi) :: jb - INTEGER(mpi) :: jsp - INTEGER(mpi) :: nan - INTEGER(mpi) :: nst - - INTEGER(mpi), INTENT(IN) :: ibuf - INTEGER(mpi), INTENT(OUT) :: nerr - SAVE - ! ... - inder(i)=readBufferDataI(i) - glder(i)=readBufferDataD(i) - isfrst(ibuf)=readBufferPointer(ibuf)+1 - islast(ibuf)=readBufferDataI(readBufferPointer(ibuf)) - - ist=isfrst(ibuf) - nst=islast(ibuf) - nerr=0 - is=ist - jsp=0 - outer: DO WHILE(is < nst) - ja=0 - jb=0 - inner1: DO - is=is+1 - IF(is > nst) EXIT outer - IF(inder(is) == 0) EXIT inner1 ! found 1. marker - END DO inner1 - ja=is - inner2: DO - is=is+1 - IF(is > nst) EXIT outer - IF(inder(is) == 0) EXIT inner2 ! found 2. marker - END DO inner2 - jb=is - IF(ja+1 == jb.AND.glder(jb) < 0.0_mpr8) THEN - ! special data - jsp=jb ! pointer to special data - is=is+NINT(-glder(jb),mpi) ! skip NSP words - CYCLE outer - END IF - DO WHILE(inder(is+1) /= 0.AND.is < nst) - is=is+1 - END DO - END DO outer - IF(is > nst) THEN - ioff = readBufferPointer(ibuf) - WRITE(*,100) readBufferDataI(ioff-1), INT(readBufferDataD(ioff),mpi) -100 FORMAT(' PEREAD: record ', I8,' in file ',I6, ' is broken !!!') - nerr=nerr+1 - ENDIF - nan=0 - DO i=ist, nst - IF(.NOT.(readBufferDataD(i) <= 0.0_mpr8).AND..NOT.(readBufferDataD(i) > 0.0_mpr8)) nan=nan+1 - END DO - IF(nan > 0) THEN - ioff = readBufferPointer(ibuf) - WRITE(*,101) readBufferDataI(ioff-1), INT(readBufferDataD(ioff),mpi), nan -101 FORMAT(' PEREAD: record ', I8,' in file ',I6, ' contains ', I6, ' NaNs !!!') - nerr= nerr+2 - ENDIF - -END SUBROUTINE pechk - -!> Decode Millepede record. -!! -!! Get indices JA, JB, IS for next measurement within record: -!! - Measurement is: GLDER(JA) -!! - Local derivatives are: -!! (INDER(JA+J),GLDER(JA+J),J=1,JB-JA-1) i.e. JB-JA-1 derivatives -!! - Standard deviation is: GLDER(JB) -!! - Global derivatives are: -!! (INDER(JB+J),GLDER(JB+J),J=1,IS-JB) i.e. IST-JB derivatives -!! -!! End_of_data is indicated by returned values JA=0 and JB=0 -!! Special data are ignored. At end_of_data the info to the -!! special data is returned: IS = pointer to special data; -!! number of words is NSP=-GLDER(IS). -!! -!! \param [in] nst index of last word of record -!! \param [in,out] is index of last global derivative -!! (index of first word of record at the first call) -!! \param [out] ja index of measured value (=0 at end), = pointer to local derivatives -!! \param [out] jb index of standard deviation (=0 at end), = pointer to global derivatives -!! \param [out] jsp index to special data -!! -SUBROUTINE isjajb(nst,is,ja,jb,jsp) - USE mpmod - - IMPLICIT NONE - REAL(mpr8) :: glder - INTEGER(mpi) :: i - INTEGER(mpi) :: inder - - INTEGER(mpi), INTENT(IN) :: nst - INTEGER(mpi), INTENT(IN OUT) :: is - INTEGER(mpi), INTENT(OUT) :: ja - INTEGER(mpi), INTENT(OUT) :: jb - INTEGER(mpi), INTENT(OUT) :: jsp - SAVE - ! ... - inder(i)=readBufferDataI(i) - glder(i)=readBufferDataD(i) - - jsp=0 - DO - ja=0 - jb=0 - IF(is >= nst) RETURN - DO - is=is+1 - IF(inder(is) == 0) EXIT - END DO - ja=is - DO - is=is+1 - IF(inder(is) == 0) EXIT - END DO - jb=is - IF(ja+1 == jb.AND.glder(jb) < 0.0_mpr8) THEN - ! special data - jsp=jb ! pointer to special data - is=is+NINT(-glder(jb),mpi) ! skip NSP words - CYCLE - END IF - DO WHILE(inder(is+1) /= 0.AND.is < nst) - is=is+1 - END DO - EXIT - END DO - -END SUBROUTINE isjajb - - -!*********************************************************************** -! LOOPN ... -!> \ref sssec-loopn "Loop" with fits and sums. -!! -!! Loop over all binary files. Perform local fits to calculate Chi2, ndf -!! and r.h.s. 'b' of linear equation system A*x=b. In first iteration(s) -!! fill matrix A. - -SUBROUTINE loopn - USE mpmod - - IMPLICIT NONE - REAL(mpd) :: dsum - REAL(mps) :: elmt - REAL(mpd) :: factrj - REAL(mpd) :: factrk - REAL(mpr8) :: glder - REAL(mps) :: peakd - REAL(mps) :: peaki - REAL(mps) :: ratae - REAL(mpd) :: rhs - REAL(mps) :: rloop - REAL(mpd) :: sgm - REAL(mps) :: used - REAL(mps) :: usei - REAL(mpd) :: weight - INTEGER(mpi) :: i - INTEGER(mpi) :: ia - INTEGER(mpi) :: ib - INTEGER(mpi) :: ibuf - INTEGER(mpi) :: inder - INTEGER(mpi) :: ioffb - INTEGER(mpi) :: ipr - INTEGER(mpi) :: isfrst - INTEGER(mpi) :: islast - INTEGER(mpi) :: itgbi - INTEGER(mpi) :: itgbij - INTEGER(mpi) :: itgbik - INTEGER(mpi) :: ivgb - INTEGER(mpi) :: ivgbij - INTEGER(mpi) :: ivgbik - INTEGER(mpi) :: j - INTEGER(mpi) :: k - INTEGER(mpi) :: lastit - INTEGER(mpi) :: lun - INTEGER(mpi) :: ncrit - INTEGER(mpi) :: ndfs - INTEGER(mpi) :: ngras - INTEGER(mpi) :: nparl - INTEGER(mpi) :: nr - INTEGER(mpi) :: nrej - INTEGER(mpi) :: inone - INTEGER(mpi) :: ilow - INTEGER(mpi) :: nlow - INTEGER(mpi) :: nzero - LOGICAL :: btest - - REAL(mpd):: adder - REAL(mpd)::funref - REAL(mpd)::dchi2s - REAL(mpd)::sndf - INTEGER(mpl):: ii - SAVE - ! ... - isfrst(ibuf)=readBufferPointer(ibuf)+1 - islast(ibuf)=readBufferDataI(readBufferPointer(ibuf)) - inder(i)=readBufferDataI(i) - glder(i)=readBufferDataD(i) - ! ----- book and reset --------------------------------------------- - IF(nloopn == 0) THEN ! first call - lastit=-1 - iitera=0 - END IF - - nloopn=nloopn+1 ! increase loop counter - ndfsum=0 - sumndf=0.0_mpd - funref=0.0_mpd - - IF(nloopn == 1) THEN ! book histograms for 1. iteration - CALL gmpdef(1,4,'Function value in iterations') - IF (metsol == 3 .OR. metsol == 4) THEN ! extend to GMRES, i.e. 4? - CALL gmpdef(2,3,'Number of MINRES steps vs iteration nr') - END IF - CALL hmpdef( 5,0.0,0.0,'Number of degrees of freedom') - CALL hmpdef(11,0.0,0.0,'Number of local parameters') - CALL hmpdef(23,0.0,0.0, 'SQRT of diagonal elements without presigma') - CALL hmpdef(24,0.0,0.0, 'Log10 of off-diagonal elements') - CALL hmpdef(25,0.0,0.0, 'Relative individual pre-sigma') - CALL hmpdef(26,0.0,0.0, 'Relative global pre-sigma') - END IF - - - CALL hmpdef(3,-prange,prange, & ! book - 'Normalized residuals of single (global) measurement') - CALL hmpdef(12,-prange,prange, & ! book - 'Normalized residuals of single (local) measurement') - CALL hmpdef(13,-prange,prange, & ! book - 'Pulls of single (global) measurement') - CALL hmpdef(14,-prange,prange, & ! book - 'Pulls of single (local) measurement') - CALL hmpdef(4,0.0,0.0,'Chi^2/Ndf after local fit') - CALL gmpdef(4,5,'location, dispersion (res.) vs record nr') - CALL gmpdef(5,5,'location, dispersion (pull) vs record nr') - - ! WRITE(*,*) 'LOOPN ', NLOOPN, ' executing ICALCM=', ICALCM - - ! reset - - globalVector=0.0_mpd ! reset rhs vector IGVEC - globalCounter=0 - IF(icalcm == 1) THEN - globalMatD=0.0_mpd - globalMatF=0. - IF (metsol >= 3) matPreCond=0.0_mpd - END IF - - IF(nloopn == 2) CALL hmpdef(6,0.0,0.0,'Down-weight fraction') - - newite=.FALSE. - IF(iterat /= lastit) THEN ! new iteration - newite=.TRUE. - funref=fvalue - IF(nloopn > 1) THEN - nrej=nrejec(0)+nrejec(1)+nrejec(2)+nrejec(3) - ! CALL MEND - IF(iterat == 1) THEN - chicut=chirem - ELSE IF(iterat >= 1) THEN - chicut=SQRT(chicut) - IF(chicut /= 0.0.AND.chicut < 1.5) chicut=1.0 - IF(chicut /= 0.0.AND.nrej == 0) chicut=1.0 - END IF - END IF - ! WRITE(*,111) ! header line - END IF - - DO i=0,3 - nrejec(i)=0 ! reset reject counter - END DO - DO k=3,6 - writeBufferHeader(k)=0 ! cache usage - writeBufferHeader(-k)=0 - END DO - ! statistics per binary file - DO i=1,nfilb - jfd(i)=0 - cfd(i)=0.0 - dfd(i)=0 - END DO - - IF (imonit /= 0) measHists=0 ! reset monitoring histograms - - ! ----- read next data ---------------------------------------------- - DO - CALL peread(nr) ! read records - CALL peprep(1) ! prepare records - ndfs =0 - sndf =0.0_mpd - dchi2s=0.0_mpd - CALL loopbf(nrejec,ndfs,sndf,dchi2s,nfiles,jfd,cfd,dfd) - ndfsum=ndfsum+ndfs - sumndf=sumndf+sndf - CALL addsum(dchi2s) - IF (nr <= 0) EXIT ! next block of events ? - END DO - ! sum up RHS (over threads) once (reduction in LOOPBF: summation for each block) - ioffb=0 - DO ipr=2,mthrd - ioffb=ioffb+lenGlobalVec - DO k=1,lenGlobalVec - globalVector(k)=globalVector(k)+globalVector(ioffb+k) - globalCounter(k)=globalCounter(k)+globalCounter(ioffb+k) - END DO - END DO - - IF (icalcm == 1) THEN - ! PRINT *, ' cache/w ',(writeBufferHeader(-K),K=3,6),(writeBufferHeader(K),K=3,6) - nparl=writeBufferHeader(3) - ncrit=writeBufferHeader(4) - used=REAL(writeBufferHeader(-5),mps)/REAL(writeBufferHeader(-3),mps)*0.1 - usei=REAL(writeBufferHeader(5),mps)/REAL(writeBufferHeader(3),mps)*0.1 - peakd=REAL(writeBufferHeader(-6),mps)*0.1 - peaki=REAL(writeBufferHeader(6),mps)*0.1 - WRITE(*,111) nparl,ncrit,usei,used,peaki,peakd -111 FORMAT(' Write cache usage (#flush,#overrun,,', & - 'peak(levels))'/2I7,',',4(f6.1,'%')) - ! fill second half (j>i) of global matric for extended storage - IF (mextnd > 0) CALL mhalf2() - END IF - - ! check entries/counters - nlow=0 - ilow=1 - nzero=0 - DO i=1,nvgb - IF(globalCounter(i) == 0) nzero=nzero+1 - IF(globalCounter(i) < mreqena) THEN - nlow=nlow+1 - IF(globalCounter(i) < globalCounter(ilow)) ilow=i - END IF - END DO - IF(nlow > 0) THEN - nalow=nalow+nlow - itgbi=globalParVarToTotal(ilow) - print * - print *, " ... warning ..." - print *, " global parameters with too few (< MREQENA) accepted entries: ", nlow - print *, " minimum entries: ", globalCounter(ilow), " for label ", globalParLabelIndex(1,itgbi) - print * - END IF - IF(icalcm == 1 .AND. nzero > 0) THEN - ndefec = nzero ! rank defect - WRITE(*,*) 'Warning: the rank defect of the symmetric',nfgb, & - '-by-',nfgb,' matrix is ',ndefec,' (should be zero).' - WRITE(lun,*) 'Warning: the rank defect of the symmetric',nfgb, & - '-by-',nfgb,' matrix is ',ndefec,' (should be zero).' - IF (iforce == 0) THEN - isubit=1 - WRITE(*,*) ' --> enforcing SUBITO mode' - WRITE(lun,*) ' --> enforcing SUBITO mode' - END IF - END IF - - ! ----- after end-of-data add contributions from pre-sigma --------- - - IF(nloopn == 1) THEN - ! plot diagonal elements - elmt=0.0 - DO i=1,nvgb ! diagonal elements - ii=0 - IF(matsto == 1) THEN - ii=i - ii=(ii*ii+ii)/2 - END IF - IF(matsto == 2) ii=i - IF(matsto == 3) ii=i - IF(ii /= 0) THEN - elmt=REAL(globalMatD(ii),mps) - IF(elmt > 0.0) CALL hmpent(23,1.0/SQRT(elmt)) - END IF - END DO - END IF - - - - ! add pre-sigma contributions to matrix diagonal - - ! WRITE(*,*) 'Adding to diagonal ICALCM IND6',ICALCM,IND6 - - IF(icalcm == 1) THEN - DO ivgb=1,nvgb ! add evtl. pre-sigma - ! WRITE(*,*) 'Index ',IVGB,IVGB,QM(IND6+IVGB) - IF(globalParPreWeight(ivgb) /= 0.0) THEN - IF(ivgb > 0) CALL mupdat(ivgb,ivgb,globalParPreWeight(ivgb)) - END IF - END DO - END IF - - CALL hmpwrt(23) - CALL hmpwrt(24) - CALL hmpwrt(25) - CALL hmpwrt(26) - - - ! add regularization term to F and to rhs -------------------------- - - ! WRITE(*,*) 'NREGUL ',NREGUL,NLOOPN - - IF(nregul /= 0) THEN ! add regularization term to F and to rhs - DO ivgb=1,nvgb - itgbi=globalParVarToTotal(ivgb) ! global parameter index - globalVector(ivgb)=globalVector(ivgb) -globalParameter(itgbi)*globalParPreWeight(ivgb) - adder=globalParPreWeight(ivgb)*globalParameter(itgbi)**2 - CALL addsum(adder) - END DO - END IF - - - ! ----- add contributions from "measurement" ----------------------- - - - i=1 - DO WHILE (i <= lenMeasurements) - rhs=listMeasurements(i )%value ! right hand side - sgm=listMeasurements(i+1)%value ! sigma parameter - i=i+2 - weight=0.0 - IF(sgm > 0.0) weight=1.0/sgm**2 - - dsum=-rhs - - ! loop over label/factor pairs - ia=i - DO - i=i+1 - IF(i > lenMeasurements) EXIT - IF(listMeasurements(i)%label == 0) EXIT - END DO - ib=i-1 - - DO j=ia,ib - factrj=listMeasurements(j)%value - itgbij=inone(listMeasurements(j)%label) ! total parameter index - IF(itgbij /= 0) THEN - dsum=dsum+factrj*globalParameter(itgbij) ! residuum - END IF - ! add to vector - ivgbij=0 - IF(itgbij /= 0) ivgbij=globalParLabelIndex(2,itgbij) ! variable-parameter index - IF(ivgbij > 0) THEN - globalVector(ivgbij)=globalVector(ivgbij) -weight*dsum*factrj ! vector - globalCounter(ivgbij)=globalCounter(ivgbij)+1 - END IF - - IF(icalcm == 1.AND.ivgbij > 0) THEN - DO k=ia,j - factrk=listMeasurements(k)%value - itgbik=inone(listMeasurements(k)%label) ! total parameter index - ! add to matrix - ivgbik=0 - IF(itgbik /= 0) ivgbik=globalParLabelIndex(2,itgbik) ! variable-parameter index - IF(ivgbij > 0.AND.ivgbik > 0) THEN ! - CALL mupdat(ivgbij,ivgbik,weight*factrj*factrk) - END IF - END DO - END IF - END DO - - adder=weight*dsum**2 - CALL addsum(adder) ! accumulate chi-square - - END DO - - ! ----- printout --------------------------------------------------- - - - CALL getsum(fvalue) ! get accurate sum (Chi^2) - flines=0.5_mpd*fvalue ! Likelihood function value - rloop=iterat+0.01*nloopn - actfun=REAL(funref-fvalue,mps) - IF(nloopn == 1) actfun=0.0 - ngras=nint(angras,mpi) - ratae=0.0 !!! - IF(delfun /= 0.0) THEN - ratae=MIN(99.9,actfun/delfun) !!! - ratae=MAX(-99.9,ratae) - END IF - - ! rejects ... - - nrej =nrejec(0)+nrejec(1)+nrejec(2)+nrejec(3) - IF(nloopn == 1) THEN - IF(nrej /= 0) THEN - WRITE(*,*) ' ' - WRITE(*,*) 'Data rejected in initial loop:' - WRITE(*,*) ' ', & - nrejec(0), ' (rank deficit/NaN) ',nrejec(1),' (Ndf=0) ', & - nrejec(2), ' (huge) ',nrejec(3),' (large)' - END IF - END IF - ! IF(NREJEC(1)+NREJEC(2)+NREJEC(3).NE.0) THEN - ! WRITE(LUNLOG,*) 'Data rejected in initial loop:',NREJEC(1), - ! + ' (Ndf=0) ',NREJEC(2),' (huge) ',NREJEC(3),' (large)' - ! END IF - - - IF(newite.AND.iterat == 2) THEN - IF(nrecpr /= 0.OR.nrecp2 /= 0) nrecer=nrec3 - IF(nrecpr < 0) THEN - nrecpr=nrec1 - END IF - IF(nrecp2 < 0) THEN - nrecp2=nrec2 - END IF - END IF - - IF(nloopn <= 2) THEN - IF(nhistp /= 0) THEN - ! CALL HMPRNT(3) ! scaled residual of single measurement - ! CALL HMPRNT(12) ! scaled residual of single measurement - ! CALL HMPRNT(4) ! chi^2/Ndf - END IF - CALL hmpwrt(3) - CALL hmpwrt(12) - CALL hmpwrt(4) - CALL gmpwrt(4) ! location, dispersion (res.) as a function of record nr - IF (nloopn <= lfitnp) THEN - CALL hmpwrt(13) - CALL hmpwrt(14) - CALL gmpwrt(5) ! location, dispersion (pull) as a function of record nr - END IF - END IF - ! IF(NLOOPN.EQ.2.AND.NHISTP.NE.0) CALL HMPRNT(6) - IF(nloopn == 2) CALL hmpwrt(6) - IF(nloopn <= 1) THEN - ! IF(NHISTP.NE.0) CALL HMPRNT(5) ! number of degrees of freedom - ! IF(NHISTP.NE.0) CALL HMPRNT(11) ! Nlocal - CALL hmpwrt(5) - CALL hmpwrt(11) - END IF - - ! local fit: band matrix structure !? - IF (nloopn == 1.AND.nbndr(1)+nbndr(2) > 0) THEN - DO lun=6,8,2 - WRITE(lun,*) ' ' - WRITE(lun,*) ' === local fits have bordered band matrix structure ===' - IF (nbndr(1) > 0 ) WRITE(lun,101) ' NBNDR',nbndr(1),'number of records (upper/left border)' - IF (nbndr(2) > 0 ) WRITE(lun,101) ' NBNDR',nbndr(2),'number of records (lower/right border)' - WRITE(lun,101) ' NBDRX',nbdrx,'max border size' - WRITE(lun,101) ' NBNDX',nbndx,'max band width' - END DO - END IF - - lastit=iterat - - ! monitoring of residuals - IF (imonit < 0 .OR. (nloopn == 1 .AND. btest(imonit,0))) CALL monres - -101 FORMAT(1X,a8,' =',i10,' = ',a) -! 101 FORMAT(' LOOPN',I6,' Function value',F22.8,10X,I6,' records') -! 102 FORMAT(' incl. constraint penalty',F22.8) -! 103 FORMAT(I13,3X,A,G12.4) -END SUBROUTINE loopn ! loop with fits - -!> Print title for iteration. -!! -!! \param [in] lunp unit number - -SUBROUTINE ploopa(lunp) - USE mpmod - - IMPLICIT NONE - - INTEGER(mpi), INTENT(IN) :: lunp - ! .. - WRITE(lunp,*) ' ' - WRITE(lunp,101) ! header line - WRITE(lunp,102) ! header line -101 FORMAT(' it fc',' fcn_value dfcn_exp slpr costh iit st', & - ' ls step cutf',1X,'rejects hhmmss FMS') -102 FORMAT(' -- --',' ----------- -------- ---- ----- --- --', & - ' -- ----- ----',1X,'------- ------ ---') - RETURN -END SUBROUTINE ploopa ! title for iteration - -!> Print iteration line. -!! -!! \param [in] lunp unit number - -SUBROUTINE ploopb(lunp) - USE mpmod - - IMPLICIT NONE - INTEGER(mpi) :: ma - INTEGER :: minut - INTEGER(mpi) :: nfa - INTEGER :: nhour - INTEGER(mpi) :: nrej - INTEGER(mpi) :: nsecnd - REAL(mps) :: ratae - REAL :: rstb - REAL(mps) :: secnd - REAL(mps) :: slopes(3) - REAL(mps) :: steps(3) - REAL, DIMENSION(2) :: ta - - INTEGER(mpi), INTENT(IN) :: lunp - - CHARACTER (LEN=4):: ccalcm(4) - DATA ccalcm / ' end',' S', ' F ',' FMS' / - SAVE - - nrej=nrejec(0)+nrejec(1)+nrejec(2)+nrejec(3) ! rejects - IF(nrej > 9999999) nrej=9999999 - CALL etime(ta,rstb) - deltim=rstb-rstart - CALL sechms(deltim,nhour,minut,secnd) ! time - nsecnd=nint(secnd,mpi) - IF(iterat == 0) THEN - WRITE(lunp,103) iterat,nloopn,fvalue, & - chicut,nrej,nhour,minut,nsecnd,ccalcm(lcalcm) - ELSE - IF (lsinfo == 10) THEN ! line search skipped - WRITE(lunp,105) iterat,nloopn,fvalue,delfun, & - iitera,istopa,chicut,nrej,nhour,minut,nsecnd,ccalcm(lcalcm) - ELSE - CALL ptlopt(nfa,ma,slopes,steps) ! slopes steps - ratae=MAX(-99.9,MIN(99.9,slopes(2)/slopes(1))) - stepl=steps(2) - WRITE(lunp,104) iterat,nloopn,fvalue,delfun,ratae,angras, & - iitera,istopa,lsinfo,stepl, chicut,nrej,nhour,minut,nsecnd,ccalcm(lcalcm) - ENDIF - END IF -103 FORMAT(i3,i3,e12.5,38X,f5.1, 1X,i7, i3,i2.2,i2.2,a4) -104 FORMAT(i3,i3,e12.5,1X,e8.2,f6.3,f6.3,i5,2I3,f6.3,f5.1, & - 1X,i7, i3,i2.2,i2.2,a4) -105 FORMAT(i3,i3,e12.5,1X,e8.2,12X,i5,I3,9X,f5.1, & - 1X,i7, i3,i2.2,i2.2,a4) - RETURN -END SUBROUTINE ploopb ! iteration line - -!> Print sub-iteration line. -!! -!! \param [in] lunp unit number - -SUBROUTINE ploopc(lunp) - USE mpmod - - IMPLICIT NONE - INTEGER(mpi) :: ma - INTEGER(mpi) :: minut - INTEGER(mpi) :: nfa - INTEGER(mpi) :: nhour - INTEGER(mpi) :: nrej - INTEGER(mpi) :: nsecnd - REAL(mps) :: ratae - REAL :: rstb - REAL(mps) :: secnd - REAL(mps) :: slopes(3) - REAL(mps) :: steps(3) - REAL, DIMENSION(2) :: ta - - INTEGER(mpi), INTENT(IN) :: lunp - CHARACTER (LEN=4):: ccalcm(4) - DATA ccalcm / ' end',' S', ' F ',' FMS' / - SAVE - - nrej=nrejec(0)+nrejec(1)+nrejec(2)+nrejec(3) ! rejects - IF(nrej > 9999999) nrej=9999999 - CALL etime(ta,rstb) - deltim=rstb-rstart - CALL sechms(deltim,nhour,minut,secnd) ! time - nsecnd=nint(secnd,mpi) - IF (lsinfo == 10) THEN ! line search skipped - WRITE(lunp,104) nloopn,fvalue,nrej,nhour,minut,nsecnd,ccalcm(lcalcm) - ELSE - CALL ptlopt(nfa,ma,slopes,steps) ! slopes steps - ratae=ABS(slopes(2)/slopes(1)) - stepl=steps(2) - WRITE(lunp,105) nloopn,fvalue, ratae,lsinfo, & - stepl,nrej,nhour,minut,nsecnd,ccalcm(lcalcm) - END IF -104 FORMAT(3X,i3,e12.5,9X, 35X, i7, i3,i2.2,i2.2,a4) -105 FORMAT(3X,i3,e12.5,9X, f6.3,14X,i3,f6.3,6X, i7, i3,i2.2,i2.2,a4) - RETURN - -END SUBROUTINE ploopc ! sub-iteration line - -!> Print solution line. -!! -!! \param [in] lunp unit number - -SUBROUTINE ploopd(lunp) - USE mpmod - IMPLICIT NONE - INTEGER :: minut - INTEGER :: nhour - INTEGER(mpi) :: nsecnd - REAL :: rstb - REAL(mps) :: secnd - REAL, DIMENSION(2) :: ta - - - INTEGER(mpi), INTENT(IN) :: lunp - CHARACTER (LEN=4):: ccalcm(4) - DATA ccalcm / ' end',' S', ' F ',' FMS' / - SAVE - CALL etime(ta,rstb) - deltim=rstb-rstart - CALL sechms(deltim,nhour,minut,secnd) ! time - nsecnd=NINT(secnd,mpi) - - WRITE(lunp,106) nhour,minut,nsecnd,ccalcm(lcalcm) -106 FORMAT(69X,i3,i2.2,i2.2,a4) - RETURN -END SUBROUTINE ploopd - -!> Print explanation of iteration table. -SUBROUTINE explfc(lunit) - USE mpdef - USE mpmod, ONLY: metsol - - IMPLICIT NONE - INTEGER(mpi) :: lunit - WRITE(lunit,*) ' ' - WRITE(lunit,102) 'Explanation of iteration table' - WRITE(lunit,102) '==============================' - WRITE(lunit,101) 'it', & - 'iteration number. Global parameters are improved for it > 0.' - WRITE(lunit,102) 'First function evaluation is called iteraton 0.' - WRITE(lunit,101) 'fc', 'number of function evaluations.' - WRITE(lunit,101) 'fcn_value', 'value of 2 x Likelihood function (LF).' - WRITE(lunit,102) 'The final value is the chi^2 value of the fit and should' - WRITE(lunit,102) 'be about equal to the NDF (see below).' - WRITE(lunit,101) 'dfcn_exp', & - 'expected reduction of the value of the Likelihood function (LF)' - WRITE(lunit,101) 'slpr', 'ratio of the actual slope to inital slope.' - WRITE(lunit,101) 'costh', & - 'cosine of angle between search direction and -gradient' - IF (metsol == 3) THEN - WRITE(lunit,101) 'iit', & - 'number of internal iterations in MINRES algorithm' - WRITE(lunit,101) 'st', 'stop code of MINRES algorithm' - WRITE(lunit,102) '< 0: rhs is very special, with beta2 = 0' - WRITE(lunit,102) '= 0: rhs b = 0, i.e. the exact solution is x = 0' - WRITE(lunit,102) '= 1 requested accuracy achieved, as determined by rtol' - WRITE(lunit,102) '= 2 reasonable accuracy achieved, given eps' - WRITE(lunit,102) '= 3 x has converged to an eigenvector' - WRITE(lunit,102) '= 4 matrix ill-conditioned (Acond has exceeded 0.1/eps)' - WRITE(lunit,102) '= 5 the iteration limit was reached' - WRITE(lunit,102) '= 6 Matrix x vector does not define a symmetric matrix' - WRITE(lunit,102) '= 7 Preconditioner does not define a symmetric matrix' - ELSEIF (metsol == 4) THEN - WRITE(lunit,101) 'iit', & - 'number of internal iterations in MINRES-QLP algorithm' - WRITE(lunit,101) 'st', 'stop code of MINRES-QLP algorithm' - WRITE(lunit,102) '= 1: beta_{k+1} < eps, iteration k is the final Lanczos step.' - WRITE(lunit,102) '= 2: beta2 = 0. If M = I, b and x are eigenvectors of A.' - WRITE(lunit,102) '= 3: beta1 = 0. The exact solution is x = 0.' - WRITE(lunit,102) '= 4: A solution to (poss. singular) Ax = b found, given rtol.' - WRITE(lunit,102) '= 5: A solution to (poss. singular) Ax = b found, given eps.' - WRITE(lunit,102) '= 6: Pseudoinverse solution for singular LS problem, given rtol.' - WRITE(lunit,102) '= 7: Pseudoinverse solution for singular LS problem, given eps.' - WRITE(lunit,102) '= 8: The iteration limit was reached.' - WRITE(lunit,102) '= 9: The operator defined by Aprod appears to be unsymmetric.' - WRITE(lunit,102) '=10: The operator defined by Msolve appears to be unsymmetric.' - WRITE(lunit,102) '=11: The operator defined by Msolve appears to be indefinite.' - WRITE(lunit,102) '=12: xnorm has exceeded maxxnorm or will exceed it next iteration.' - WRITE(lunit,102) '=13: Acond has exceeded Acondlim or 0.1/eps.' - WRITE(lunit,102) '=14: Least-squares problem but no converged solution yet.' - WRITE(lunit,102) '=15: A null vector obtained, given rtol.' - ENDIF - WRITE(lunit,101) 'ls', 'line search info' - WRITE(lunit,102) '< 0 recalculate function' - WRITE(lunit,102) '= 0: N or STP lt 0 or step not descending' - WRITE(lunit,102) '= 1: Linesearch convergence conditions reached' - WRITE(lunit,102) '= 2: interval of uncertainty at lower limit' - WRITE(lunit,102) '= 3: max nr of line search calls reached' - WRITE(lunit,102) '= 4: step at the lower bound' - WRITE(lunit,102) '= 5: step at the upper bound' - WRITE(lunit,102) '= 6: rounding error limitation' - WRITE(lunit,101) 'step', & - 'the factor for the Newton step during the line search. Usually' - WRITE(lunit,102) & - 'a value of 1 gives a sufficient reduction of the LF. Oherwise' - WRITE(lunit,102) 'other step values are tried.' - WRITE(lunit,101) 'cutf', & - 'cut factor. Local fits are rejected, if their chi^2 value' - WRITE(lunit,102) & - 'is larger than the 3-sigma chi^2 value times the cut factor.' - WRITE(lunit,102) 'A cut factor of 1 is used finally, but initially a larger' - WRITE(lunit,102) 'factor may be used. A value of 0.0 means no cut.' - WRITE(lunit,101) 'rejects', 'total number of rejected local fits.' - WRITE(lunit,101) 'hmmsec', 'the time in hours (h), minutes (mm) and seconds.' - WRITE(lunit,101) 'FMS', 'calculation of Function value, Matrix, Solution.' - WRITE(lunit,*) ' ' - -101 FORMAT(a9,' = ',a) -102 FORMAT(13X,a) -END SUBROUTINE explfc - -!> Update element of global matrix. -!! -!! Add value ADD to matrix element (I,J). -!! -!! \param [in] i first index -!! \param [in] j second index -!! \param [in] add summand - -SUBROUTINE mupdat(i,j,add) ! - USE mpmod - - IMPLICIT NONE - - INTEGER(mpi), INTENT(IN) :: i - INTEGER(mpi), INTENT(IN) :: j - REAL(mpd), INTENT(IN) :: add - - INTEGER(mpl):: ijadd - INTEGER(mpl):: ia - INTEGER(mpl):: ja - INTEGER(mpl):: ij - ! ... - IF(i <= 0.OR.j <= 0) RETURN - ia=MAX(i,j) ! larger - ja=MIN(i,j) ! smaller - ij=0 - IF(matsto == 1) THEN ! full symmetric matrix - ij=ja+(ia*ia-ia)/2 ! ISYM index - globalMatD(ij)=globalMatD(ij)+add - ELSE IF(matsto == 2) THEN ! sparse symmetric matrix - ij=ijadd(i,j) ! inline code requires same time - IF (ij == 0) RETURN ! pair is suppressed - IF (ij > 0) THEN - globalMatD(ij)=globalMatD(ij)+add - ELSE - globalMatF(-ij)=globalMatF(-ij)+REAL(add,mps) - END IF - END IF - IF(metsol >= 3) THEN - IF(mbandw > 0) THEN ! for Cholesky decomposition - IF(ia <= nvgb) THEN ! variable global parameter - ij=indPreCond(ia)-ia+ja - IF(ia > 1.AND.ij <= indPreCond(ia-1)) ij=0 - IF(ij /= 0) matPreCond(ij)=matPreCond(ij)+add - IF(ij < 0.OR.ij > size(matPreCond)) THEN - CALL peend(23,'Aborted, bad matrix index') - STOP 'mupdat: bad index' - END IF - ELSE ! Lagrange multiplier - ij=indPreCond(nvgb)+(ia-nvgb-1)*nvgb+ja - IF(ij /= 0) matPreCond(ij)=matPreCond(ij)+add - END IF - ELSE IF(mbandw == 0) THEN ! default preconditioner - IF(ia <= nvgb) THEN ! variable global parameter - IF(ja == ia) matPreCond(ia)=matPreCond(ia)+add ! diag - ELSE ! Lagrange multiplier - ij=nvgb+(ia-nvgb-1)*nvgb+ja - IF(ij /= 0) matPreCond(ij)=matPreCond(ij)+add - END IF - END IF - END IF -END SUBROUTINE mupdat - - -!> Loop over records in read buffer (block), fits and sums. -!! -!! Loop over records in current read buffer block (with multiple threads). -!! Perform \ref par-locfitv "local fits" (optionally with \ref par-downw -!! "outlier downweigthing") to calculate Chi2, ndf and r.h.s. 'b' of -!! linear equation system A*x=b. In first iteration(s) fill global matrix A. -!! -!! For the filling of the global matrix each thread creates from his share of local fits -!! (small) udpdate matrices (\f$\Vek{\D C}_1+\Vek{\D C}_2\f$ from equations \ref eq-c1 "(15)", -!! \ref eq-c2 "(16)") stored in a write buffer. After all events in the read buffer -!! block have been processed the global matrix is being updated from the matrices in -!! the write buffer in parallel (each row by different thread). -!! -!! The matrices of the local fits are checked for bordered band structure. -!! For border size b and band width m all elements (i,j) are zero for -!! min(i,j)>b and abs(i-j)>m. For sufficient small (b,m) a solution by -!! \ref dbcdec "root free Cholesky decomposition" and -!! forward/backward substitution of the band part -!! is much faster compared to inversion (see broken lines in references). -!! Based on the expected computing cost the faster solution method is selected. -!! -!! \param [in,out] nrej number of rejected records -!! \param [in,out] ndfs sum(ndf) -!! \param [in,out] sndf sum(weighted ndf) -!! \param [in,out] dchi2s sum(weighted chi2) -!! \param [in] numfil number of binary files -!! \param [in,out] naccf number of accepted records per binary file -!! \param [in,out] chi2f sum(chi2/ndf) per binary file -!! \param [in,out] ndff sum(ndf) per binary file - -SUBROUTINE loopbf(nrej,ndfs,sndf,dchi2s, numfil,naccf,chi2f,ndff) - USE mpmod - - IMPLICIT NONE - REAL(mpd) :: cauchy - REAL(mps) :: chichi - REAL(mps) :: chlimt - REAL(mps) :: chndf - REAL(mpd) :: chuber - REAL(mpd) :: down - REAL(mpr8) :: glder - REAL(mpd) :: pull - REAL(mpd) :: r1 - REAL(mpd) :: r2 - REAL(mps) :: rec - REAL(mpd) :: rerr - REAL(mpd) :: resid - REAL(mps) :: resing - REAL(mpd) :: resmax - REAL(mpd) :: rmeas - REAL(mpd) :: rmloc - REAL(mpd) :: suwt - REAL(mps) :: used - REAL(mpd) :: wght - REAL(mps) :: chindl - INTEGER(mpi) :: i - INTEGER(mpi) :: ia - INTEGER(mpi) :: ib - INTEGER(mpi) :: ibuf - INTEGER(mpi) :: ichunk - INTEGER(mpl) :: icmn - INTEGER(mpl) :: icost - INTEGER(mpi) :: id - INTEGER(mpi) :: idiag - INTEGER(mpi) :: iext - INTEGER(mpi) :: ij - INTEGER(mpi) :: ije - INTEGER(mpi) :: ijn - INTEGER(mpi) :: ijsym - INTEGER(mpi) :: ik - INTEGER(mpi) :: ike - INTEGER(mpi) :: im - INTEGER(mpi) :: imeas - INTEGER(mpi) :: in - INTEGER(mpi) :: inder - INTEGER(mpi) :: inv - INTEGER(mpi) :: ioffb - INTEGER(mpi) :: ioffc - INTEGER(mpi) :: ioffd - INTEGER(mpi) :: ioffe - INTEGER(mpi) :: ioffi - INTEGER(mpi) :: iprdbg - INTEGER(mpi) :: iproc - INTEGER(mpi) :: irbin - INTEGER(mpi) :: irow - INTEGER(mpi) :: isfrst - INTEGER(mpi) :: islast - INTEGER(mpi) :: ist - INTEGER(mpi) :: iter - INTEGER(mpi) :: itgbi - INTEGER(mpi) :: ivgbj - INTEGER(mpi) :: ivgbk - INTEGER(mpi) :: j - INTEGER(mpi) :: ja - INTEGER(mpi) :: jb - INTEGER(mpi) :: jk - INTEGER(mpi) :: jn - INTEGER(mpi) :: joffd - INTEGER(mpi) :: joffi - INTEGER(mpi) :: jproc - INTEGER(mpi) :: jsp - INTEGER(mpi) :: k - INTEGER(mpi) :: kbdr - INTEGER(mpi) :: kbdrx - INTEGER(mpi) :: kbnd - INTEGER(mpi) :: kfl - INTEGER(mpi) :: kx - INTEGER(mpi) :: mbdr - INTEGER(mpi) :: mbnd - INTEGER(mpi) :: mside - INTEGER(mpi) :: nalc - INTEGER(mpi) :: nalg - INTEGER(mpi) :: nan - INTEGER(mpi) :: nb - INTEGER(mpi) :: ndf - INTEGER(mpi) :: ndfsd - INTEGER(mpi) :: ndown - INTEGER(mpi) :: neq - INTEGER(mpi) :: nfred - INTEGER(mpi) :: nfrei - INTEGER(mpi) :: ngg - INTEGER(mpi) :: nprdbg - INTEGER(mpi) :: nrank - INTEGER(mpi) :: nrc - INTEGER(mpi) :: nst - INTEGER(mpi) :: nter - INTEGER(mpi) :: nweig - - INTEGER(mpi), INTENT(IN OUT) :: nrej(0:3) - INTEGER(mpi), INTENT(IN OUT) :: ndfs - REAL(mpd), INTENT(IN OUT) :: sndf - REAL(mpd), INTENT(IN OUT) :: dchi2s - INTEGER(mpi), INTENT(IN) :: numfil - INTEGER(mpi), INTENT(IN OUT) :: naccf(numfil) - REAL(mps), INTENT(IN OUT) :: chi2f(numfil) - INTEGER(mpi), INTENT(IN OUT) :: ndff(numfil) - - REAL(mpd):: dchi2 - REAL(mpd)::dvar - REAL(mpd):: dw1 - REAL(mpd)::dw2 - REAL(mpd)::summ - - !$ INTEGER(mpi) OMP_GET_THREAD_NUM - - LOGICAL:: lprnt - LOGICAL::lhist - CHARACTER (LEN=3):: chast - DATA chuber/1.345_mpd/ ! constant for Huber down-weighting - DATA cauchy/2.3849_mpd/ ! constant for Cauchy down-weighting - SAVE chuber,cauchy - ! ... - ijsym(i,j)=MIN(i,j)+(MAX(i,j)*MAX(i,j)-MAX(i,j))/2 - isfrst(ibuf)=readBufferPointer(ibuf)+1 - islast(ibuf)=readBufferDataI(readBufferPointer(ibuf)) - inder(i)=readBufferDataI(i) - glder(i)=readBufferDataD(i) - - ichunk=MIN((numReadBuffer+mthrd-1)/mthrd/32+1,256) - ! reset header, 3 words per thread: - ! number of entries, offset to data, indices - writeBufferInfo=0 - writeBufferData=0. - nprdbg=0 - iprdbg=-1 - - ! parallelize record loop - ! private copy of NDFS,.. for each thread, combined at end, init with 0. - !$OMP PARALLEL DO & - !$OMP DEFAULT(PRIVATE) & - !$OMP SHARED(numReadBuffer,readBufferPointer,readBufferDataI, & - !$OMP readBufferDataD,writeBufferHeader,writeBufferInfo, & - !$OMP writeBufferData,writeBufferIndices,writeBufferUpdates,globalVector,globalCounter, & - !$OMP globalParameter,globalParLabelIndex,globalIndexUsage,backIndexUsage, & - !$OMP measBins,numMeas,measIndex,measRes,measHists, & - !$OMP NAGB,NVGB,NAGBN,ICALCM,ICHUNK,NLOOPN,NRECER,NPRDBG,IPRDBG, & - !$OMP NEWITE,CHICUT,LHUBER,CHUBER,ITERAT,NRECPR,MTHRD, & - !$OMP DWCUT,CHHUGE,NRECP2,CAUCHY,LFITNP,LFITBB,IMONIT,IMONMD) & - !$OMP REDUCTION(+:NDFS,SNDF,DCHI2S,NREJ,NBNDR,NACCF,CHI2F,NDFF) & - !$OMP REDUCTION(MAX:NBNDX,NBDRX) & - !$OMP REDUCTION(MIN:NREC3) & - !$OMP SCHEDULE(DYNAMIC,ICHUNK) - DO ibuf=1,numReadBuffer ! buffer for current record - nrc=readBufferDataI(isfrst(ibuf)-2) ! record - kfl=NINT(readBufferDataD(isfrst(ibuf)-1),mpi) ! file - dw1=REAL(readBufferDataD(isfrst(ibuf)-2),mpd) ! weight - dw2=SQRT(dw1) - - iproc=0 - !$ IPROC=OMP_GET_THREAD_NUM() ! thread number - ioffb=nagb*iproc ! offset 'f'. - ioffc=nagbn*iproc ! offset 'c'. - ioffe=nvgb*iproc ! offset 'e' - ioffd=writeBufferHeader(-1)*iproc+writeBufferInfo(2,iproc+1) ! offset data - ioffi=writeBufferHeader(1)*iproc+writeBufferInfo(3,iproc+1)+2 ! offset indices - ! ----- reset ------------------------------------------------------ - lprnt=.FALSE. - lhist=(iproc == 0) - REC=nrc ! floating point value - IF(nloopn == 1.AND.MOD(nrc,100000) == 0) THEN - WRITE(*,*) 'Record',nrc,' ... still reading' - END IF - - ! printout/debug only for one thread at a time - - - ! flag for record printout ----------------------------------------- - - lprnt=.FALSE. - IF(newite.AND.(iterat == 1.OR.iterat == 3)) THEN - IF(nrc == nrecpr) lprnt=.TRUE. - IF(nrc == nrecp2) lprnt=.TRUE. - IF(nrc == nrecer) lprnt=.TRUE. - END IF - IF (lprnt)THEN - !$OMP ATOMIC - nprdbg=nprdbg+1 ! number of threads with debug - IF (nprdbg == 1) iprdbg=iproc ! first thread with debug - IF (iproc /= iprdbg) lprnt=.FALSE. - ! print *, ' LPRNT ', NRC, NPRDBG, IPRDBG, IPROC, LPRNT - END IF - IF(lprnt) THEN - WRITE(1,*) ' ' - WRITE(1,*) '------------------ Loop',nloopn, & - ': Printout for record',nrc,iproc - WRITE(1,*) ' ' - END IF - - ! ----- print data ------------------------------------------------- - - IF(lprnt) THEN - imeas=0 ! local derivatives - ist=isfrst(ibuf) - nst=islast(ibuf) - DO ! loop over measurements - CALL isjajb(nst,ist,ja,jb,jsp) - IF(ja == 0) EXIT - IF(imeas == 0) WRITE(1,1121) - imeas=imeas+1 - WRITE(1,1122) imeas,glder(ja),glder(jb), & - (inder(ja+j),glder(ja+j),j=1,jb-ja-1) - END DO -1121 FORMAT(/'Measured value and local derivatives'/ & - ' i measured std_dev index...derivative ...') -1122 FORMAT(i3,2G12.4,3(i3,g12.4)/(27X,3(i3,g12.4))) - - imeas=0 ! global derivatives - ist=isfrst(ibuf) - nst=islast(ibuf) - DO ! loop over measurements - CALL isjajb(nst,ist,ja,jb,jsp) - IF(ja == 0) EXIT - IF(imeas == 0) WRITE(1,1123) - imeas=imeas+1 - IF (jb < ist) THEN - IF(ist-jb > 2) THEN - WRITE(1,1124) imeas,(globalParLabelIndex(1,inder(jb+j)),inder(jb+j), & - globalParLabelIndex(2,inder(jb+j)),glder(jb+j),j=1,ist-jb) - ELSE - WRITE(1,1125) imeas,(globalParLabelIndex(1,inder(jb+j)),inder(jb+j), & - globalParLabelIndex(2,inder(jb+j)),glder(jb+j),j=1,ist-jb) - END IF - END IF - END DO -1123 FORMAT(/'Global derivatives'/ & - ' i label gindex vindex derivative ...') -1124 FORMAT(i3,2(i9,i7,i7,g12.4)/(3X,2(i9,i7,i7,g12.4))) -1125 FORMAT(i3,2(i9,i7,i7,g12.4)) - END IF - - ! ----- first loop ------------------------------------------------- - ! ------ prepare local fit ------ - ! count local and global derivates - ! subtract actual alignment parameters from the measured data - - IF(lprnt) THEN - WRITE(1,*) ' ' - WRITE(1,*) 'Data corrections using values of global parameters' - WRITE(1,*) '==================================================' - WRITE(1,101) - END IF - nalg=0 ! count number of global derivatives - nalc=0 ! count number of local derivatives - neq=0 ! count number of equations - ist=isfrst(ibuf) - nst=islast(ibuf) - DO ! loop over measurements - CALL isjajb(nst,ist,ja,jb,jsp) - IF(ja == 0) EXIT - rmeas=REAL(glder(ja),mpd) ! data - neq=neq+1 ! count equation - ! subtract global ... from measured value - DO j=1,ist-jb ! global parameter loop - itgbi=inder(jb+j) ! global parameter label - rmeas=rmeas-REAL(glder(jb+j),mpd)*globalParameter(itgbi) ! subtract !!! reversed - IF (icalcm == 1) THEN - ij=globalParLabelIndex(2,itgbi) ! index of variable global parameter - IF(ij > 0) THEN - ijn=backIndexUsage(ioffe+ij) ! get index of index - IF(ijn == 0) THEN ! not yet included - nalg=nalg+1 ! count - globalIndexUsage(ioffc+nalg)=ij ! store global index - backIndexUsage(ioffe+ij)=nalg ! store back index - END IF - END IF - END IF - END DO - IF(lprnt) THEN - IF (jb < ist) WRITE(1,102) neq,glder(ja),rmeas,glder(jb) - END IF - readBufferDataD(ja)=REAL(rmeas,mpr8) ! global contribution subtracted - DO j=1,jb-ja-1 ! local parameter loop - ij=inder(ja+j) - nalc=MAX(nalc,ij) ! number of local parameters - END DO - END DO -101 FORMAT(' index measvalue corrvalue sigma') -102 FORMAT(i6,2X,2G12.4,' +-',g12.4) - - IF(nalc <= 0) GO TO 90 - - ngg=(nalg*nalg+nalg)/2 - IF (icalcm == 1) THEN - DO k=1,nalg*nalc - localGlobalMatrix(k)=0.0_mpd ! reset global-local matrix - END DO - writeBufferIndices(ioffi-1)=nrc ! index header: - writeBufferIndices(ioffi )=nalg ! event number, number of global par - CALL sort1k(globalIndexUsage(ioffc+1),nalg) ! sort global par. - DO k=1,nalg - iext=globalIndexUsage(ioffc+k) - writeBufferIndices(ioffi+k)=iext ! global par indices - backIndexUsage(ioffe+iext)=k ! update back index - END DO - DO k=1,ngg - writeBufferUpdates(ioffd+k)=0.0_mpd ! reset global-global matrix - END DO - END IF - ! ----- iteration start and check --------------------------------- - - nter=1 ! first loop without down-weighting - IF(nloopn /= 1.AND.lhuber /= 0) nter=lhuber - localCorrections(1:neq) = 0._mpd - - ! check matrix for bordered band structure (MBDR+MBND+1 <= NALC) - mbnd=-1 - mbdr=nalc - mside=-1 ! side (1: upper/left border, 2: lower/right border) - DO i=1, 2*nalc - ibandh(i)=0 - END DO - irow=1 - idiag=1 - ndfsd=0 - - iter=0 - resmax=0.0 - DO WHILE(iter < nter) ! outlier suppresssion iteration loop - iter=iter+1 - resmax=0.0 - IF(lprnt) THEN - WRITE(1,*) ' ' - WRITE(1,*) 'Outlier-suppression iteration',iter,' of',nter - WRITE(1,*) '==========================================' - WRITE(1,*) ' ' - imeas=0 - END IF - - ! ----- second loop ------------------------------------------------ - ! accumulate normal equations for local fit and determine solution - DO i=1,nalc - blvec(i)=0.0_mpd ! reset vector - END DO - DO i=1,(nalc*nalc+nalc)/2 ! GF: FIXME - not really, local parameter number... - clmat(i)=0.0_mpd ! (p)reset matrix - END DO - neq=0 - ndown=0 - nweig=0 - ist=isfrst(ibuf) - nst=islast(ibuf) - DO ! loop over measurements - CALL isjajb(nst,ist,ja,jb,jsp) - IF(ja == 0) EXIT - rmeas=REAL(glder(ja),mpd) ! data - rerr =REAL(glder(jb),mpd) ! ... and the error - wght =1.0_mpd/rerr**2 ! weight from error - neq=neq+1 ! count equation - nweig=nweig+1 - resid=rmeas-localCorrections(neq) ! subtract previous fit - IF(nloopn /= 1.AND.iter /= 1.AND.lhuber /= 0) THEN - IF(iter <= 3) THEN - IF(ABS(resid) > chuber*rerr) THEN ! down-weighting - wght=wght*chuber*rerr/ABS(resid) - ndown=ndown+1 - END IF - ELSE ! Cauchy - wght=wght/(1.0+(resid/rerr/cauchy)**2) - END IF - END IF - - IF(lprnt.AND.iter /= 1.AND.nter /= 1) THEN - chast=' ' - IF(ABS(resid) > chuber*rerr) chast='* ' - IF(ABS(resid) > 3.0*rerr) chast='** ' - IF(ABS(resid) > 6.0*rerr) chast='***' - IF(imeas == 0) WRITE(1,*) 'Second loop: accumulate' - IF(imeas == 0) WRITE(1,103) - imeas=imeas+1 - down=1.0/SQRT(wght) - r1=resid/rerr - r2=resid/down - WRITE(1,104) imeas,rmeas,resid,rerr,r1,chast,r2 - END IF -103 FORMAT(' index corrvalue residuum sigma', & - ' nresid cnresid') -104 FORMAT(i6,2X,2G12.4,' +-',g12.4,f7.2,1X,a3,f8.2) - - DO j=1,jb-ja-1 ! normal equations, local parameter loop - ij=inder(ja+j) ! local parameter index J - blvec(ij)=blvec(ij)+wght*rmeas*REAL(glder(ja+j),mpd) - DO k=1,j - ik=inder(ja+k) ! local parameter index K - jk=ijsym(ij,ik) ! index in symmetric matrix - clmat(jk)=clmat(jk) & ! force double precision - +wght*REAL(glder(ja+j),mpd)*REAL(glder(ja+k),mpd) - ! check for band matrix substructure - IF (iter == 1) THEN - id=IABS(ij-ik)+1 - im=MIN(ij,ik) ! upper/left border - ibandh(id)=MAX(ibandh(id),im) - im=MIN(nalc+1-ij,nalc+1-ik) ! lower/rght border (mirrored) - ibandh(nalc+id)=MAX(ibandh(nalc+id),im) - END IF - END DO - END DO - END DO - ! for non trivial fits check for bordered band matrix structure - IF (iter == 1.AND.nalc > 5.AND.lfitbb > 0) THEN - kx=-1 - kbdrx=0 - icmn=INT(nalc,mpl)**3 ! cost (*6) should improve by at least factor 2 - ! upper/left border ? - kbdr=0 - DO k=nalc,2,-1 - kbnd=k-2 - kbdr=MAX(kbdr,ibandh(k)) - icost=6*INT(nalc-kbdr,mpl)*INT(kbnd+kbdr+1,mpl)**2+2*INT(kbdr,mpl)**3 - IF (icost < icmn) THEN - icmn=icost - kx=k - kbdrx=kbdr - mside=1 - END IF - END DO - IF (kx < 0) THEN - ! lower/right border instead? - kbdr=0 - DO k=nalc,2,-1 - kbnd=k-2 - kbdr=MAX(kbdr,ibandh(k+nalc)) - icost=6*INT(nalc-kbdr,mpl)*INT(kbnd+kbdr+1,mpl)**2+2*INT(kbdr,mpl)**3 - IF (icost < icmn) THEN - icmn=icost - kx=k - kbdrx=kbdr - mside=2 - END IF - END DO - END IF - IF (kx > 0) THEN - mbnd=kx-2 - mbdr=kbdrx - END IF - END IF - - IF (mbnd >= 0) THEN - ! fast solution for border banded matrix (inverse for ICALCM>0) - IF (nloopn == 1) THEN - nbndr(mside)=nbndr(mside)+1 - nbdrx=MAX(nbdrx,mbdr) - nbndx=MAX(nbndx,mbnd) - END IF - - inv=0 - IF (nloopn <= lfitnp.AND.iter == 1) inv=1 ! band part of inverse (for pulls) - IF (icalcm == 1.OR.lprnt) inv=2 ! complete inverse - IF (mside == 1) THEN - CALL sqmibb(clmat,blvec,nalc,mbdr,mbnd,inv,nrank, & - vbnd,vbdr,aux,vbk,vzru,scdiag,scflag) - ELSE - CALL sqmibb2(clmat,blvec,nalc,mbdr,mbnd,inv,nrank, & - vbnd,vbdr,aux,vbk,vzru,scdiag,scflag) - ENDIF - ELSE - ! full inversion and solution - inv=2 - CALL sqminv(clmat,blvec,nalc,nrank,scdiag,scflag) - END IF - ! check for NaNs - nan=0 - DO k=1, nalc - IF ((.NOT.(blvec(k) <= 0.0_mpd)).AND. (.NOT.(blvec(k) > 0.0_mpd))) nan=nan+1 - END DO - - IF(lprnt) THEN - WRITE(1,*) ' ' - WRITE(1,*) 'Parameter determination:',nalc,' parameters,', ' rank=',nrank - WRITE(1,*) '-----------------------' - IF(ndown /= 0) WRITE(1,*) ' ',ndown,' data down-weighted' - WRITE(1,*) ' ' - END IF - - ! ----- third loop ------------------------------------------------- - ! calculate single residuals remaining after local fit and chi^2 - - summ=0.0_mpd - suwt=0.0 - neq=0 - imeas=0 - ist=isfrst(ibuf) - nst=islast(ibuf) - DO ! loop over measurements - CALL isjajb(nst,ist,ja,jb,jsp) - IF(ja == 0) EXIT - rmeas=REAL(glder(ja),mpd) ! data (global contrib. subtracted) - rerr =REAL(glder(jb),mpd) ! ... and the error - wght =1.0_mpd/rerr**2 ! weight from error - neq=neq+1 ! count equation - rmloc=0.0 ! local fit result reset - DO j=1,jb-ja-1 ! local parameter loop - ij=inder(ja+j) - rmloc=rmloc+REAL(glder(ja+j),mpd)*blvec(ij) ! local fit result - END DO - localCorrections(neq)=rmloc ! save local fit result - rmeas=rmeas-rmloc ! reduced to residual - - ! calculate pulls? (needs covariance matrix) - IF(iter == 1.AND.inv > 0.AND.nloopn <= lfitnp) THEN - dvar=0.0_mpd - DO j=1,jb-ja-1 - ij=inder(ja+j) - DO k=1,jb-ja-1 - ik=inder(ja+k) - jk=ijsym(ij,ik) - dvar=dvar+clmat(jk)*REAL(glder(ja+j),mpd)*REAL(glder(ja+k),mpd) - END DO - END DO - ! some variance left to define a pull? - IF (0.999999_mpd/wght > dvar) THEN - pull=rmeas/SQRT(1.0_mpd/wght-dvar) - IF (lhist) THEN - IF (jb < ist) THEN - CALL hmpent(13,REAL(pull,mps)) ! histogram pull - CALL gmpms(5,REC,REAL(pull,mps)) - ELSE - CALL hmpent(14,REAL(pull,mps)) ! histogram pull - END IF - END IF - ! monitoring - IF (imonit /= 0) THEN - IF (jb < ist) THEN - ij=inder(jb+1) ! group by first global label - if (imonmd == 0) THEN - irbin=MIN(measBins,max(1,INT(pull*rerr/measRes(ij)/measBinSize+0.5*REAL(measBins,mpd)))) - ELSE - irbin=MIN(measBins,max(1,INT(pull/measBinSize+0.5*REAL(measBins,mpd)))) - ENDIF - irbin=irbin+measBins*(measIndex(ij)-1+numMeas*iproc) - measHists(irbin)=measHists(irbin)+1 - ENDIF - ENDIF - END IF - END IF - - IF(iter == 1.AND.jb < ist.AND.lhist) & - CALL gmpms(4,REC,REAL(rmeas/rerr,mps)) ! residual (with global deriv.) - - dchi2=wght*rmeas*rmeas - ! DCHIT=DCHI2 - resid=rmeas - IF(nloopn /= 1.AND.iter /= 1.AND.lhuber /= 0) THEN - IF(iter <= 3) THEN - IF(ABS(resid) > chuber*rerr) THEN ! down-weighting - wght=wght*chuber*rerr/ABS(resid) - dchi2=2.0*chuber*(ABS(resid)/rerr-0.5*chuber) - END IF - ELSE - wght=wght/(1.0_mpd+(resid/rerr/cauchy)**2) - dchi2=LOG(1.0_mpd+(resid/rerr/cauchy)**2)*cauchy**2 - END IF - END IF - - down=1.0/SQRT(wght) - - ! SUWT=SUWT+DCHI2/DCHIT - suwt=suwt+rerr/down - IF(lprnt) THEN - chast=' ' - IF(ABS(resid) > chuber*rerr) chast='* ' - IF(ABS(resid) > 3.0*rerr) chast='** ' - IF(ABS(resid) > 6.0*rerr) chast='***' - IF(imeas == 0) WRITE(1,*) 'Third loop: single residuals' - IF(imeas == 0) WRITE(1,105) - imeas=imeas+1 - r1=resid/rerr - r2=resid/down - IF(resid < 0.0) r1=-r1 - IF(resid < 0.0) r2=-r2 - WRITE(1,106) imeas,glder(ja),rmeas,rerr,r1,chast,r2 - END IF -105 FORMAT(' index corrvalue residuum sigma', & - ' nresid cnresid') -106 FORMAT(i6,2X,2G12.4,' +-',g12.4,f7.2,1X,a3,f8.2) - - IF(iter == nter) THEN - readBufferDataD(ja)=REAL(rmeas,mpr8) ! store remaining residual - resmax=MAX(resmax,ABS(rmeas)/rerr) - END IF - - IF(iter == 1.AND.lhist) THEN - IF (jb < ist) THEN - CALL hmpent( 3,REAL(rmeas/rerr,mps)) ! histogram norm residual - ELSE - CALL hmpent(12,REAL(rmeas/rerr,mps)) ! histogram norm residual - END IF - END IF - summ=summ+dchi2 ! accumulate chi-square sum - END DO - ndf=neq-nrank - resing=(REAL(nweig,mps)-REAL(suwt,mps))/REAL(nweig,mps) - IF (lhist) THEN - IF(iter == 1) CALL hmpent( 5,REAL(ndf,mps)) ! histogram Ndf - IF(iter == 1) CALL hmpent(11,REAL(nalc,mps)) ! histogram Nlocal - IF(nloopn == 2.AND.iter == nter) CALL hmpent(6,resing) - END IF - IF(lprnt) THEN - WRITE(1,*) ' ' - WRITE(1,*) 'Chi^2=',summ,' at',ndf,' degrees of freedom: ', & - '3-sigma limit is',chindl(3,ndf)*REAL(ndf,mps) - WRITE(1,*) suwt,' is sum of factors, compared to',nweig, & - ' Downweight fraction:',resing - END IF - IF(nrank /= nalc.OR.nan > 0) THEN - nrej(0)=nrej(0)+1 ! count cases - IF (nrec3 == huge(nrec3)) nrec3=nrc - IF(lprnt) THEN - WRITE(1,*) ' rank deficit/NaN ', nalc, nrank, nan - WRITE(1,*) ' ---> rejected!' - END IF - GO TO 90 - END IF - IF(ndf <= 0) THEN - nrej(1)=nrej(1)+1 ! count cases - IF(lprnt) THEN - WRITE(1,*) ' ---> rejected!' - END IF - GO TO 90 - END IF - - chndf=REAL(summ/REAL(ndf,mpd),mps) - - IF(iter == 1.AND.lhist) CALL hmpent(4,chndf) ! histogram chi^2/Ndf - END DO ! outlier iteration loop - - ndfs=ndfs+ndf ! (local) sum of Ndf - sndf=sndf+REAL(ndf,mpd)*dw1 ! (local) weighted sum of Ndf - - ! ----- reject eventually ------------------------------------------ - - IF(newite.AND.iterat == 2) THEN ! find record with largest Chi^2/Ndf - IF(nrecp2 < 0.AND.chndf > writeBufferData(2,iproc+1)) THEN - writeBufferData(2,iproc+1)=chndf - writeBufferInfo(7,iproc+1)=nrc - END IF - END IF - - chichi=chindl(3,ndf)*REAL(ndf,mps) - ! GF IF(SUMM.GT.50.0*CHICHI) THEN ! huge - ! CHK CHICUT<0: NO cut (1st iteration) - IF(chicut >= 0.0) THEN - IF(summ > chhuge*chichi) THEN ! huge - nrej(2)=nrej(2)+1 ! count cases with huge chi^2 - IF(lprnt) THEN - WRITE(1,*) ' ---> rejected!' - END IF - GO TO 90 - END IF - - IF(chicut > 0.0) THEN - chlimt=chicut*chichi - ! WRITE(*,*) 'chi^2 ',SUMM,CHLIMT,CHICUT,CHINDL(3,NDF),NDF - IF(summ > chlimt) THEN - IF(lprnt) THEN - WRITE(1,*) ' ---> rejected!' - END IF - ! add to FVALUE - dchi2=chlimt ! total contribution limit - dchi2s=dchi2s+dchi2*dw1 ! add total contribution - nrej(3)=nrej(3)+1 ! count cases with large chi^2 - GO TO 90 - END IF - END IF - END IF - - IF(lhuber > 1.AND.dwcut /= 0.0.AND.resing > dwcut) THEN - ! add to FVALUE - dchi2=summ ! total contribution - dchi2s=dchi2s+dchi2*dw1 ! add total contribution - nrej(3)=nrej(3)+1 ! count cases with large chi^2 - ! WRITE(*,*) 'Downweight fraction cut ',RESING,DWCUT,SUMM - IF(lprnt) THEN - WRITE(1,*) ' ---> rejected!' - END IF - GO TO 90 - END IF - - IF(newite.AND.iterat == 2) THEN ! find record with largest residual - IF(nrecpr < 0.AND.resmax > writeBufferData(1,iproc+1)) THEN - writeBufferData(1,iproc+1)=REAL(resmax,mps) - writeBufferInfo(6,iproc+1)=nrc - END IF - END IF - ! 'track quality' per binary file: accepted records - naccf(kfl)=naccf(kfl)+1 - ndff(kfl) =ndff(kfl) +ndf - chi2f(kfl)=chi2f(kfl)+chndf - - ! ----- fourth loop ------------------------------------------------ - ! update of global matrix and vector according to the "Millepede" - ! principle, from the global/local information - - ist=isfrst(ibuf) - nst=islast(ibuf) - DO ! loop over measurements - CALL isjajb(nst,ist,ja,jb,jsp) - IF(ja <= 0) EXIT - - rmeas=REAL(glder(ja),mpd) ! data residual - rerr =REAL(glder(jb),mpd) ! ... and the error - wght =1.0_mpd/rerr**2 ! weight from measurement error - dchi2=wght*rmeas*rmeas ! least-square contribution - - IF(nloopn /= 1.AND.lhuber /= 0) THEN ! check residual - resid=ABS(rmeas) - IF(resid > chuber*rerr) THEN - wght=wght*chuber*rerr/resid ! down-weighting - dchi2=2.0*chuber*(resid/rerr-0.5*chuber) ! modified contribution - END IF - END IF - dchi2s=dchi2s+dchi2*dw1 ! add to total objective function - - ! global-global matrix contribution: add directly to gg-matrix - - DO j=1,ist-jb - ivgbj=globalParLabelIndex(2,inder(jb+j)) ! variable-parameter index - IF(ivgbj > 0) THEN - globalVector(ioffb+ivgbj)=globalVector(ioffb+ivgbj) & - +dw1*wght*rmeas*REAL(glder(jb+j),mpd) ! vector !!! reverse - globalCounter(ioffb+ivgbj)=globalCounter(ioffb+ivgbj)+1 - IF(icalcm == 1) THEN - ije=backIndexUsage(ioffe+ivgbj) ! get index of index, non-zero - DO k=1,j - ivgbk=globalParLabelIndex(2,inder(jb+k)) - IF(ivgbk > 0) THEN - ike=backIndexUsage(ioffe+ivgbk) ! get index of index, non-zero - ia=MAX(ije,ike) ! larger - ib=MIN(ije,ike) ! smaller - ij=ib+(ia*ia-ia)/2 - writeBufferUpdates(ioffd+ij)=writeBufferUpdates(ioffd+ij) & - -dw1*wght*REAL(glder(jb+j),mpd)*REAL(glder(jb+k),mpd) - END IF - END DO - END IF - END IF - END DO - - ! normal equations - rectangular matrix for global/local pars - ! global-local matrix contribution: accumulate rectangular matrix - IF (icalcm /= 1) CYCLE - DO j=1,ist-jb - ivgbj=globalParLabelIndex(2,inder(jb+j)) ! variable-parameter index - IF(ivgbj > 0) THEN - ije=backIndexUsage(ioffe+ivgbj) ! get index of index, non-zero - DO k=1,jb-ja-1 - ik=inder(ja+k) ! local index - jk=ik+(ije-1)*nalc ! matrix index - localGlobalMatrix(jk)=localGlobalMatrix(jk)+dw2*wght*REAL(glder(jb+j),mpd)*REAL(glder(ja+k),mpd) - END DO - END IF - END DO - END DO - - - ! ----- final matrix update ---------------------------------------- - ! update global matrices and vectors - IF(icalcm /= 1) GO TO 90 ! matrix update - ! (inverse local matrix) * (rectang. matrix) -> CORM - ! T - ! resulting symmetrix matrix = G * Gamma^{-1} * G - - CALL dbavat(clmat,localGlobalMatrix,writeBufferUpdates(ioffd+1),nalc,-nalg) - - ! (rectang. matrix) * (local param vector) -> CORV - ! resulting vector = G * q (q = local parameter) - ! CALL DBGAX(DQ(IGLMA/2+1),BLVEC,DQ(ICORV/2+1),NALG,NALC) ! not done - ! the vector update is not done, because after local fit it is zero! - - ! update cache status - writeBufferInfo(1,iproc+1)=writeBufferInfo(1,iproc+1)+1 - writeBufferInfo(2,iproc+1)=writeBufferInfo(2,iproc+1)+ngg - writeBufferInfo(3,iproc+1)=writeBufferInfo(3,iproc+1)+nalg+2 - ! check free space - nfred=writeBufferHeader(-1)-writeBufferInfo(2,iproc+1)-writeBufferHeader(-2) - nfrei=writeBufferHeader(1)-writeBufferInfo(3,iproc+1)-writeBufferHeader(2) - IF (nfred < 0.OR.nfrei < 0) THEN ! need to flush - nb=writeBufferInfo(1,iproc+1) - joffd=writeBufferHeader(-1)*iproc ! offset data - joffi=writeBufferHeader(1)*iproc+2 ! offset indices - used=REAL(writeBufferInfo(2,iproc+1),mps)/REAL(writeBufferHeader(-1),mps) - writeBufferInfo(4,iproc+1)=writeBufferInfo(4,iproc+1) +NINT(1000.0*used,mpi) - used=REAL(writeBufferInfo(3,iproc+1),mps)/REAL(writeBufferHeader(1),mps) - writeBufferInfo(5,iproc+1)=writeBufferInfo(5,iproc+1) +NINT(1000.0*used,mpi) - !$OMP CRITICAL - writeBufferHeader(-4)=writeBufferHeader(-4)+1 - writeBufferHeader(4)=writeBufferHeader(4)+1 - - DO ib=1,nb - ijn=0 - DO in=1,writeBufferIndices(joffi) - i=writeBufferIndices(joffi+in) - ! DQ(IGVEC/2+I)=DQ(IGVEC/2+I)+DQ(ICORV/2+IN) ! not done: = zero - DO jn=1,in - ijn=ijn+1 - j=writeBufferIndices(joffi+jn) - CALL mupdat(i,j,-writeBufferUpdates(joffd+ijn)) ! matrix update - END DO - END DO - joffd=joffd+ijn - joffi=joffi+writeBufferIndices(joffi)+2 - END DO - !$OMP END CRITICAL - ! reset counter, pointers - DO k=1,3 - writeBufferInfo(k,iproc+1)=0 - END DO - END IF - -90 IF(lprnt) THEN - WRITE(1,*) ' ' - WRITE(1,*) '------------------ End of printout for record',nrc - WRITE(1,*) ' ' - END IF - - DO i=1,nalg ! reset global index array - iext=globalIndexUsage(ioffc+i) - backIndexUsage(ioffe+iext)=0 - END DO - - END DO - !$OMP END PARALLEL DO - - IF (icalcm == 1) THEN - ! flush remaining matrices - DO k=1,mthrd ! update statistics - writeBufferHeader(-3)=writeBufferHeader(-3)+1 - used=REAL(writeBufferInfo(2,k),mps)/REAL(writeBufferHeader(-1),mps) - writeBufferInfo(4,k)=writeBufferInfo(4,k)+NINT(1000.0*used,mpi) - writeBufferHeader(-5)=writeBufferHeader(-5)+writeBufferInfo(4,k) - writeBufferHeader(-6)=MAX(writeBufferHeader(-6),writeBufferInfo(4,k)) - writeBufferInfo(4,k)=0 - writeBufferHeader(3)=writeBufferHeader(3)+1 - used=REAL(writeBufferInfo(3,k),mps)/REAL(writeBufferHeader(1),mps) - writeBufferInfo(5,k)=writeBufferInfo(5,k)+NINT(1000.0*used,mpi) - writeBufferHeader(5)=writeBufferHeader(5)+writeBufferInfo(5,k) - writeBufferHeader(6)=MAX(writeBufferHeader(6),writeBufferInfo(5,k)) - writeBufferInfo(5,k)=0 - END DO - - !$OMP PARALLEL & - !$OMP DEFAULT(PRIVATE) & - !$OMP SHARED(writeBufferHeader,writeBufferInfo,writeBufferIndices,writeBufferUpdates,MTHRD) - iproc=0 - !$ IPROC=OMP_GET_THREAD_NUM() ! thread number - DO jproc=0,mthrd-1 - nb=writeBufferInfo(1,jproc+1) - ! print *, ' flush end ', JPROC, NRC, NB - joffd=writeBufferHeader(-1)*jproc ! offset data - joffi=writeBufferHeader(1)*jproc+2 ! offset indices - DO ib=1,nb - ! print *, ' buf end ', JPROC,IB,writeBufferIndices(JOFFI-1),writeBufferIndices(JOFFI) - ijn=0 - DO in=1,writeBufferIndices(joffi) - i=writeBufferIndices(joffi+in) - !$ IF (MOD(I,MTHRD).EQ.IPROC) THEN - DO jn=1,in - ijn=ijn+1 - j=writeBufferIndices(joffi+jn) - CALL mupdat(i,j,-writeBufferUpdates(joffd+ijn)) ! matrix update - END DO - !$ ELSE - !$ IJN=IJN+IN - !$ ENDIF - END DO - joffd=joffd+ijn - joffi=joffi+writeBufferIndices(joffi)+2 - END DO - END DO - !$OMP END PARALLEL - END IF - - IF(newite.AND.iterat == 2) THEN ! get worst records (for printrecord -1 -1) - IF (nrecpr < 0) THEN - DO k=1,mthrd - IF (writeBufferData(1,k) > value1) THEN - value1=writeBufferData(1,k) - nrec1 =writeBufferInfo(6,k) - END IF - END DO - END IF - IF (nrecp2 < 0) THEN - DO k=1,mthrd - IF (writeBufferData(2,k) > value2) THEN - value2=writeBufferData(2,k) - nrec2 =writeBufferInfo(7,k) - END IF - END DO - END IF - END IF - -END SUBROUTINE loopbf - - - - -!*********************************************************************** - -!> Print final log file -!! -!! For each global parameter: -!! - label (I10) -!! - parameter value (G14.5) -!! - presigma (G14.5) -!! - difference of parameters values (G14.5) -!! - difference at last iteration (G14.5) -!! - error (standard deviation) (G14.5) -!! - global correlation (F8.3), on request only -!! - Entries from binary files or during iterations -!! -SUBROUTINE prtglo - USE mpmod - - IMPLICIT NONE - REAL(mps):: dpa - REAL(mps):: err - REAL(mps):: gcor - INTEGER(mpi) :: i - INTEGER(mpi) :: icount - INTEGER(mpi) :: ie - INTEGER(mpi) :: iev - INTEGER(mpi) :: ij - INTEGER(mpi) :: imin - INTEGER(mpi) :: iprlim - INTEGER(mpi) :: isub - INTEGER(mpi) :: itgbi - INTEGER(mpi) :: itgbl - INTEGER(mpi) :: ivgbi - INTEGER(mpi) :: j - INTEGER(mpi) :: label - INTEGER(mpi) :: lup - REAL(mps):: par - - REAL(mpd):: diag - REAL(mpd)::gmati - REAL(mpd)::gcor2 - INTEGER(mpi) :: labele(3) - INTEGER(mpl):: ii - REAL(mps):: compnt(3) - SAVE - ! ... - - lup=09 - CALL mvopen(lup,'millepede.res') - - WRITE(*,*) ' ' - WRITE(*,*) ' Result of fit for global parameters' - WRITE(*,*) ' ===================================' - WRITE(*,*) ' ' - - WRITE(*,101) - - WRITE(lup,*) 'Parameter ! first 3 elements per line are', & - ' significant (if used as input)' - - - iprlim=10 - DO itgbi=1,ntgb ! all parameter variables - itgbl=globalParLabelIndex(1,itgbi) - ivgbi=globalParLabelIndex(2,itgbi) - par=REAL(globalParameter(itgbi),mps) ! initial value - icount=0 ! counts - IF(ivgbi > 0) THEN - icount=globalCounter(ivgbi) ! used in last iteration - dpa=REAL(globalParameter(itgbi)-globalParStart(itgbi),mps) ! difference - IF(metsol == 1.OR.metsol == 2) THEN - ii=ivgbi - ii=(ii*ii+ii)/2 - gmati=globalMatD(ii) - ERR=SQRT(ABS(REAL(gmati,mps))) - IF(gmati < 0.0_mpd) ERR=-ERR - diag=workspaceDiag(ivgbi) - gcor=-1.0 - IF(gmati*diag > 0.0_mpd) THEN ! global correlation - gcor2=1.0_mpd-1.0_mpd/(gmati*diag) - IF(gcor2 >= 0.0_mpd.AND.gcor2 <= 1.0_mpd) gcor=REAL(SQRT(gcor2),mps) - END IF - END IF - END IF - IF(ipcntr > 1) icount=globalParCounts(itgbi) ! from binary files - IF(itgbi <= iprlim) THEN - IF(ivgbi <= 0) THEN - WRITE(* ,102) itgbl,par,REAL(globalParPreSigma(itgbi),mps) - ELSE - IF(metsol == 1.OR.metsol == 2) THEN - IF (igcorr == 0) THEN - WRITE(*,102) itgbl,par,REAL(globalParPreSigma(itgbi),mps),dpa,ERR - ELSE - WRITE(*,102) itgbl,par,REAL(globalParPreSigma(itgbi),mps),dpa,ERR,gcor - END IF - ELSE - WRITE(*,102) itgbl,par,REAL(globalParPreSigma(itgbi),mps),dpa - END IF - END IF - ELSE IF(itgbi == iprlim+1) THEN - WRITE(* ,*) '... (further printout suppressed, but see log file)' - END IF - - ! file output - IF(ivgbi <= 0) THEN - IF (ipcntr /= 0) THEN - WRITE(lup,110) itgbl,par,REAL(globalParPreSigma(itgbi),mps),icount - ELSE - WRITE(lup,102) itgbl,par,REAL(globalParPreSigma(itgbi),mps) - END IF - ELSE - IF(metsol == 1.OR.metsol == 2) THEN - IF (ipcntr /= 0) THEN - WRITE(lup,112) itgbl,par,REAL(globalParPreSigma(itgbi),mps),dpa,ERR,icount - ELSE IF (igcorr /= 0) THEN - WRITE(lup,102) itgbl,par,REAL(globalParPreSigma(itgbi),mps),dpa,ERR,gcor - ELSE - WRITE(lup,102) itgbl,par,REAL(globalParPreSigma(itgbi),mps),dpa,ERR - END IF - ELSE - IF (ipcntr /= 0) THEN - WRITE(lup,111) itgbl,par,REAL(globalParPreSigma(itgbi),mps),dpa,icount - ELSE - WRITE(lup,102) itgbl,par,REAL(globalParPreSigma(itgbi),mps),dpa - END IF - END IF - END IF - END DO - REWIND lup - CLOSE(UNIT=lup) - - IF(metsol == 2) THEN ! diagonalisation: write eigenvectors - CALL mvopen(lup,'millepede.eve') - imin=1 - DO i=nagb,1,-1 - IF(workspaceEigenValues(i) > 0.0_mpd) THEN - imin=i ! index of smallest pos. eigenvalue - EXIT - ENDIF - END DO - iev=0 - - DO isub=0,MIN(15,imin-1) - IF(isub < 10) THEN - i=imin-isub - ELSE - i=isub-9 - END IF - - ! DO I=IMIN,MAX(1,IMIN-9),-1 ! backward loop, up to 10 vectors - WRITE(*,*) 'Eigenvector ',i,' with eigenvalue',workspaceEigenValues(i) - WRITE(lup,*) 'Eigenvector ',i,' with eigenvalue',workspaceEigenValues(i) - DO j=1,nagb - ij=j+(i-1)*nagb ! index with eigenvector array - IF(j <= nvgb) THEN - itgbi=globalParVarToTotal(j) - label=globalParLabelIndex(1,itgbi) - ELSE - label=nvgb-j ! label negative for constraints - END IF - iev=iev+1 - labele(iev)=label - compnt(iev)=REAL(workspaceEigenVectors(ij),mps) ! component - IF(iev == 3) THEN - WRITE(lup,103) (labele(ie),compnt(ie),ie=1,iev) - iev=0 - END IF - END DO - IF(iev /= 0) WRITE(lup,103) (labele(ie),compnt(ie),ie=1,iev) - iev=0 - WRITE(lup,*) ' ' - END DO - - END IF - -101 FORMAT(1X,' label parameter presigma differ', & - ' error'/ 1X,'-----------',4X,4('-------------')) -102 FORMAT(i10,2X,4G14.5,f8.3) -103 FORMAT(3(i11,f11.7,2X)) -110 FORMAT(i10,2X,2G14.5,28X,i12) -111 FORMAT(i10,2X,3G14.5,14X,i12) -112 FORMAT(i10,2X,4G14.5,i12) -END SUBROUTINE prtglo ! print final log file - -!*********************************************************************** - -!> Print input statistic -!! -!! For each global parameter: -!! - label (I10) -!! - parameter value (G14.5) -!! - presigma (G14.5) -!! - difference of parameters values (G14.5), = 0. -!! - Entries from binary files -!! -SUBROUTINE prtstat - USE mpmod - - IMPLICIT NONE - REAL(mps):: par - REAL(mps):: presig - INTEGER(mpi) :: icount - INTEGER(mpi) :: itgbi - INTEGER(mpi) :: itgbl - INTEGER(mpi) :: ivgbi - INTEGER(mpi) :: lup - INTEGER(mpi) :: ncon - INTEGER(mpi) :: k - - SAVE - ! ... - - lup=09 - CALL mvopen(lup,'millepede.res') - WRITE(lup,*) '*** Results of checking input only, no solution performed ***' - WRITE(lup,*) '! fixed-1: by pre-sigma, -2: by entries cut, -3: by iterated entries cut' - WRITE(lup,*) '! Label Value Pre-sigma Entries Constraints Status ' - !iprlim=10 - DO itgbi=1,ntgb ! all parameter variables - itgbl=globalParLabelIndex(1,itgbi) - ivgbi=globalParLabelIndex(2,itgbi) - par=REAL(globalParameter(itgbi),mps) ! initial value - presig=REAL(globalParPreSigma(itgbi),mps) ! initial presigma - icount=globalParCounts(itgbi) ! from binary files - ncon=globalParCons(itgbi) ! number of active constraints - - IF (ivgbi <= 0) THEN - WRITE(lup,110) itgbl,par,presig,icount,ncon,ivgbi - ELSE - WRITE(lup,111) itgbl,par,presig,icount,ncon - END IF - END DO - ! appearance statistics - IF (icheck > 1) THEN - WRITE(lup,*) '! ' - WRITE(lup,*) '! Appearance statistics ' - WRITE(lup,*) '! Label First file and record Last file and record #files #paired-par' - DO itgbi=1,ntgb - WRITE(lup,112) globalParLabelIndex(1,itgbi), (appearanceCounter(itgbi*5+k), k=-4,0), pairCounter(itgbi) - END DO - END IF - REWIND lup - CLOSE(UNIT=lup) - -110 FORMAT(' ! ',i10,2X,2G14.5,2i12,' fixed',I2) -111 FORMAT(' ! ',i10,2X,2G14.5,2i12,' variable') -112 FORMAT(' !.',i10,6i11) -END SUBROUTINE prtstat ! print input statistics - - -!> Product symmetric matrix times vector. -!! -!! A(sym) * X => B. Used by \ref minresmodule::minres "MINRES" method (Is most CPU intensive part). -!! The matrix A is the global matrix in full symmetric or (compressed) sparse storage. -!! -!! \param [in] n size of matrix -!! \param [in] x vector X -!! \param [in] b result vector B - -SUBROUTINE avprd0(n,x,b) - USE mpmod - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: iencdb - INTEGER(mpi) :: iencdm - INTEGER(mpi) :: iproc - INTEGER(mpi) :: ir - INTEGER(mpi) :: j - INTEGER(mpi) :: jc - INTEGER(mpi) :: jj - INTEGER(mpi) :: jn - - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN) :: x(n) - REAL(mpd), INTENT(OUT) :: b(n) - INTEGER(mpl) :: k - INTEGER(mpl) :: kk - INTEGER(mpl) :: kl - INTEGER(mpl) :: ku - INTEGER(mpl) :: ll - INTEGER(mpl) :: lj - INTEGER(mpl) :: indij - INTEGER(mpl) :: indid - INTEGER(mpl) :: ij - INTEGER(mpi) :: ichunk - !$ INTEGER(mpi) OMP_GET_THREAD_NUM - SAVE - ! ... - !$ DO i=1,n - !$ b(i)=0.0_mpd ! reset 'global' B() - !$ END DO - ichunk=MIN((n+mthrd-1)/mthrd/8+1,1024) - IF(matsto == 1) THEN - ! full symmetric matrix - ! parallelize row loop - ! private copy of B(N) for each thread, combined at end, init with 0. - ! slot of 1024 'I' for next idle thread - !$OMP PARALLEL DO & - !$OMP PRIVATE(J,IJ) & - !$OMP REDUCTION(+:B) & - !$OMP SCHEDULE(DYNAMIC,ichunk) - DO i=1,n - ij=i - ij=(ij*ij-ij)/2 - b(i)=globalMatD(ij+i)*x(i) - DO j=1,i-1 - b(j)=b(j)+globalMatD(ij+j)*x(i) - b(i)=b(i)+globalMatD(ij+j)*x(j) - END DO - END DO - !$OMP END PARALLEL DO - ELSE - ! sparse, compressed matrix - IF(sparseMatrixOffsets(2,1) /= n+1) THEN - CALL peend(24,'Aborted, vector/matrix size mismatch') - STOP 'AVPRD0: mismatched vector and matrix' - END IF - iencdb=nencdb - iencdm=ishft(1,iencdb)-1 - ! parallelize row loop - ! slot of 1024 'I' for next idle thread - !$OMP PARALLEL DO & - !$OMP PRIVATE(IR,K,KK,LL,KL,KU,INDID,INDIJ,J,JC,JN,LJ,JJ) & - !$OMP REDUCTION(+:B) & - !$OMP SCHEDULE(DYNAMIC,ichunk) - DO i=1,n - iproc=0 - !$ IPROC=OMP_GET_THREAD_NUM() ! thread number - b(i)=globalMatD(i)*x(i) ! diagonal elements - ! ! off-diagonals double precision - ir=i - kk=sparseMatrixOffsets(1,ir) ! offset in 'd' (column lists) - ll=sparseMatrixOffsets(2,ir) ! offset in 'j' (matrix) - kl=0 - ku=sparseMatrixOffsets(1,ir+1)-1-kk - indid=kk - indij=ll - IF (sparseMatrixColumns(indid) /= 0) THEN ! no compression - DO k=kl,ku - j=sparseMatrixColumns(indid+k) - b(j)=b(j)+globalMatD(indij+k)*x(i) - b(i)=b(i)+globalMatD(indij+k)*x(j) - END DO - ELSE - lj=0 - ku=((ku+1)*8)/9-1 ! number of regions (-1) - indid=indid+ku/8+1 ! skip group offsets - IF (mextnd>0) THEN - ! extended storage - DO kl=0,ku - jc=sparseMatrixColumns(indid+kl) - j=ishft(jc,-iencdb) - jn=IAND(jc, iencdm) - b(i)=b(i)+dot_product(globalMatD(indij+lj:indij+lj+jn-1),x(j:j+jn-1)) - lj=lj+jn - END DO - ELSE - DO kl=0,ku - jc=sparseMatrixColumns(indid+kl) - j=ishft(jc,-iencdb) - jn=IAND(jc, iencdm) - DO jj=1,jn - b(j)=b(j)+globalMatD(indij+lj)*x(i) - b(i)=b(i)+globalMatD(indij+lj)*x(j) - j=j+1 - lj=lj+1 - END DO - END DO - END IF - END IF - - IF (nspc > 1) THEN - ir=i+n+1 ! off-diagonals single precision - kk=sparseMatrixOffsets(1,ir) ! offset in 'd' (column lists) - ll=sparseMatrixOffsets(2,ir) ! offset in '.' (matrix) - kl=0 - ku=sparseMatrixOffsets(1,ir+1)-1-kk - indid=kk - indij=ll - IF (sparseMatrixColumns(indid) /= 0) THEN ! no compression - DO k=kl,ku - j=sparseMatrixColumns(indid+k) - b(j)=b(j)+REAL(globalMatF(indij+k),mpd)*x(i) - b(i)=b(i)+REAL(globalMatF(indij+k),mpd)*x(j) - END DO - ELSE - lj=0 - ku=((ku+1)*8)/9-1 ! number of regions (-1) - indid=indid+ku/8+1 ! skip group offsets - DO kl=0,ku - jc=sparseMatrixColumns(indid+kl) - j=ishft(jc,-iencdb) - jn=IAND(jc, iencdm) - IF (mextnd>0) THEN - ! extended storage - DO jj=1,jn - b(i)=b(i)+REAL(globalMatF(indij+lj),mpd)*x(j) - j=j+1 - lj=lj+1 - END DO - ELSE - DO jj=1,jn - b(j)=b(j)+REAL(globalMatF(indij+lj),mpd)*x(i) - b(i)=b(i)+REAL(globalMatF(indij+lj),mpd)*x(j) - j=j+1 - lj=lj+1 - END DO - END IF - END DO - END IF - END IF - END DO - ENDIF - -END SUBROUTINE avprd0 - -!> Product symmetric matrix times vector. -!! -!! A(sym) * X => B. Used by \ref minresmodule::minres "MINRES" method (Is most CPU intensive part). -!! The matrix A is the global matrix in full symmetric or (compressed) sparse storage. -!! Allows for size of X and smaller than size of matrix in case of solution with constriants by elimination. -!! -!! \param [in] n size of matrix ( <= size of global matrix) -!! \param [in] x vector X -!! \param [in] b result vector B - -SUBROUTINE avprod(n,x,b) - USE mpmod - - IMPLICIT NONE - - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN) :: x(n) - REAL(mpd), INTENT(OUT) :: b(n) - - SAVE - ! ... - IF(n > nagb) THEN - CALL peend(24,'Aborted, vector/matrix size mismatch') - STOP 'AVPROD: mismatched vector and matrix' - END IF - ! input to AVPRD0 - vecXav(1:n)=x - vecXav(n+1:nagb)=0.0_mpd - !use elimination for constraints ? - IF(n < nagb) CALL qlmlq(vecXav,1,.false.) ! Q*x - ! calclulate vecBav=globalMat*vecXav - CALL AVPRD0(nagb,vecXav,vecBav) - !use elimination for constraints ? - IF(n < nagb) CALL qlmlq(vecBav,1,.true.) ! Q^t*x - ! output from AVPRD0 - b=vecBav(1:n) - -END SUBROUTINE avprod - - -!> Index for sparse storage. -!! -!! In case of (compressed) sparse storage calculate index for off-diagonal matrix element. -!! -!! \param [in] itema row number -!! \param [in] itemb column number -!! \return index (>(<) 0: double(single) precision element, =0: not existing) - -FUNCTION ijadd(itema,itemb) ! index using "d" and "z" - USE mpmod - - IMPLICIT NONE - INTEGER(mpi) :: iencdb - INTEGER(mpi) :: iencdm - INTEGER(mpi) :: isgn - INTEGER(mpi) :: ispc - INTEGER(mpi) :: item2 - INTEGER(mpi) :: jtem - INTEGER(mpi) :: jtemc - INTEGER(mpi) :: jtemn - - INTEGER(mpi), INTENT(IN) :: itema - INTEGER(mpi), INTENT(IN) :: itemb - - INTEGER(mpl) :: ijadd - INTEGER(mpl) :: k - INTEGER(mpl) :: kk - INTEGER(mpl) :: kl - INTEGER(mpl) :: ku - INTEGER(mpl) :: indid - INTEGER(mpl) :: nd - INTEGER(mpl) :: ll - INTEGER(mpl) :: k8 - INTEGER(mpl) :: item1 - ! ... - ijadd=0 - nd=sparseMatrixOffsets(2,1)-1 ! dimension of matrix - item1=MAX(itema,itemb) ! larger index - item2=MIN(itema,itemb) ! smaller index - IF(item2 <= 0.OR.item1 > nd) RETURN - IF(item1 == item2) THEN ! diagonal element - ijadd=item1 - RETURN - END IF - ! ! off-diagonal element - iencdb=nencdb ! encoding info - iencdm=ishft(1,iencdb)-1 - isgn=-1 - outer: DO ispc=1,nspc - kk=sparseMatrixOffsets(1,item1) ! offset in 'd' (column lists) - ll=sparseMatrixOffsets(2,item1) ! offset in 'j' (matrix) - kl=0 - ku=sparseMatrixOffsets(1,item1+1)-1-kk - indid=kk - item1=item1+nd+1 - isgn=-isgn - IF (sparseMatrixColumns(indid) == 0) THEN ! compression ? - - ku=((ku+1)*8)/9-1 ! number of regions (-1) - indid=indid+ku/8+1 ! skip group offsets - kl=0 - IF(ku < kl) CYCLE outer ! not found - DO - k=(kl+ku)/2 ! binary search - jtemc=sparseMatrixColumns(indid+k) ! compressed information - jtem =ishft(jtemc,-iencdb) ! first column of region - jtemn=jtem+IAND(jtemc,iencdm) ! first column after region - IF(item2 >= jtem.AND.item2 < jtemn) EXIT ! found - IF(item2 < jtem) THEN - ku=k-1 - ELSE IF(item2 >= jtemn) THEN - kl=k+1 - END IF - IF(kl <= ku) CYCLE - CYCLE outer ! not found - END DO - k8=k/8 ! region group (-1) - ll=ll+sparseMatrixColumns(kk+k8) ! offset for group of (8) regions - DO kl=k8*8,k-1 - ll=ll+IAND(sparseMatrixColumns(indid+kl),iencdm) ! add region lengths - END DO - ijadd=ll+item2-jtem - - ELSE - - IF(ku < kl) CYCLE outer ! not found - DO - k=(kl+ku)/2 ! binary search - jtem=sparseMatrixColumns(indid+k) - jtemn=jtem - IF(item2 == jtem) EXIT ! found - IF(item2 < jtem) THEN - ku=k-1 - ELSE IF(item2 > jtem) THEN - kl=k+1 - END IF - IF(kl <= ku) CYCLE - CYCLE outer ! not found - END DO - ijadd=ll+k - - END IF - ijadd=ijadd*isgn - RETURN - END DO outer - -END FUNCTION ijadd - -!> Fill 2nd half of matrix for extended storage. -!! - -SUBROUTINE mhalf2 - USE mpmod - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ichunk - INTEGER(mpi) :: iencdb - INTEGER(mpi) :: iencdm - INTEGER(mpi) :: ir - INTEGER(mpi) :: ispc - INTEGER(mpi) :: j - INTEGER(mpi) :: jtem - INTEGER(mpi) :: jtemc - INTEGER(mpi) :: jtemn - INTEGER(mpi) :: nd - - INTEGER(mpl) :: ij - INTEGER(mpl) :: ijadd - INTEGER(mpl) :: k - INTEGER(mpl) :: kk - INTEGER(mpl) :: kl - INTEGER(mpl) :: ku - INTEGER(mpl) :: indid - INTEGER(mpl) :: ll - INTEGER(mpl) :: k8 - ! ... - - nd=INT(sparseMatrixOffsets(2,1),mpi)-1 ! dimension of matrix - ichunk=MIN((nd+mthrd-1)/mthrd/8+1,1024) - - iencdb=nencdb ! encoding info - iencdm=ishft(1,iencdb)-1 - DO ispc=1,nspc - ! parallelize row loop - ! slot of 1024 'I' for next idle thread - !$OMP PARALLEL DO & - !$OMP PRIVATE(I,IR,K,KK,LL,KL,KU,K8,INDID,IJ,J,JTEMC,JTEM,JTEMN) & - !$OMP SCHEDULE(DYNAMIC,ichunk) - DO i=1,nd - ir=i+(ispc-1)*(nd+1) - kk=sparseMatrixOffsets(1,ir) ! offset in 'd' (column lists) - ll=sparseMatrixOffsets(2,ir) ! offset in 'j' (matrix) - kl=sparseMatrixCompression(i+(ispc-1)*nd) ! number of regions in 1st half (j Time conversion. -!! -!! Convert from seconds to hours, minues, seconds -!! -!! \param [in] deltat time in seconds -!! \param [out] nhour hours -!! \param [out] minut minutes -!! \param [out] secnd seconds - -SUBROUTINE sechms(deltat,nhour,minut,secnd) - USE mpdef - - IMPLICIT NONE - REAL(mps), INTENT(IN) :: deltat - INTEGER(mpi), INTENT(OUT) :: minut - INTEGER(mpi), INTENT(OUT):: nhour - REAL(mps), INTENT(OUT):: secnd - INTEGER(mpi) :: nsecd - ! DELTAT = time in sec -> NHOUR,MINUT,SECND - ! ... - nsecd=nint(deltat,mpi) ! -> integer - nhour=nsecd/3600 - minut=nsecd/60-60*nhour - secnd=deltat-60*(minut+60*nhour) -END SUBROUTINE sechms - -!> Translate labels to indices (for global parameters). -!! -!! Functions INONE and subroutine UPONE are -!! used to collect items, i.e. labels, and to order and translate them. -!! -!! In the first phase items are collected and stored by calling -!! IRES=INONE(ITEM). -!! -!! At the first entry the two sub-arrays "a" (globalParLabelIndex) -!! and "b" (globalParHashTable) of length 2N -!! are generated with a start length for N=128 entries. -!! In array "a" two words are reserved for each item: (ITEM, count). -!! The function INONE(ITEM) returns the number of the item. -!! At each entry the argument is compared with the already stored items, -!! new items are stored. Search -!! for entries is done using hash-indices, stored in sub-array "b". -!! The initial hash-index is -!! -!! j = 1 + mod(ITEM, n_prime) + N -!! -!! where n_prime is the largest prime number less than N. -!! At each entry the count is increased by one. If N items are stored, -!! the size of the sub-arrays is increased by calling -!! CALL UPONE. -!! -!! \param[in] item label -!! \return index - -INTEGER(mpi) FUNCTION inone(item) ! translate 1-D identifier to nrs - USE mpmod - USE mpdalc - - IMPLICIT NONE - INTEGER(mpi), INTENT(IN) :: item - INTEGER(mpi) :: j - INTEGER(mpi) :: k - INTEGER(mpi) :: iprime - INTEGER(mpl) :: length - INTEGER(mpl), PARAMETER :: two = 2 - - inone=0 - IF(item <= 0) RETURN - IF(globalParHeader(-1) == 0) THEN - length=128 ! initial number - CALL mpalloc(globalParLabelIndex,two,length,'INONE: label & index') - CALL mpalloc(globalParHashTable,2*length,'INONE: hash pointer') - globalParHashTable = 0 - globalParHeader(-0)=INT(length,mpi) ! length of labels/indices - globalParHeader(-1)=0 ! number of stored items - globalParHeader(-2)=0 ! =0 during build-up - globalParHeader(-3)=INT(length,mpi) ! next number - globalParHeader(-4)=iprime(globalParHeader(-0)) ! prime number - globalParHeader(-5)=0 ! number of overflows - globalParHeader(-6)=0 ! nr of variable parameters - END IF - outer: DO - j=1+MOD(item,globalParHeader(-4))+globalParHeader(-0) - inner: DO ! normal case: find item - k=j - j=globalParHashTable(k) - IF(j == 0) EXIT inner ! unused hash code - IF(item == globalParLabelIndex(1,j)) EXIT outer ! found - END DO inner - ! not found - IF(globalParHeader(-1) == globalParHeader(-0).OR.globalParHeader(-2) /= 0) THEN - globalParHeader(-5)=globalParHeader(-5)+1 ! overflow - j=0 - RETURN - END IF - globalParHeader(-1)=globalParHeader(-1)+1 ! increase number of elements - globalParHeader(-3)=globalParHeader(-1) - j=globalParHeader(-1) - globalParHashTable(k)=j ! hash index - globalParLabelIndex(1,j)=item ! add new item - globalParLabelIndex(2,j)=0 ! reset counter - IF(globalParHeader(-1) /= globalParHeader(-0)) EXIT outer - ! update with larger dimension and redefine index - globalParHeader(-3)=globalParHeader(-3)*2 - CALL upone - IF (lvllog > 1) WRITE(lunlog,*) 'INONE: array increased to', & - globalParHeader(-3),' words' - END DO outer - - IF(globalParHeader(-2) == 0) THEN - globalParLabelIndex(2,j)=globalParLabelIndex(2,j)+1 ! increase counter - globalParHeader(-7)=globalParHeader(-7)+1 - END IF - inone=j -END FUNCTION inone - -!> Update, redefine hash indices. -SUBROUTINE upone - USE mpmod - USE mpdalc - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: j - INTEGER(mpi) :: k - INTEGER(mpi) :: iprime - INTEGER(mpi) :: nused - LOGICAL :: finalUpdate - INTEGER(mpl) :: oldLength - INTEGER(mpl) :: newLength - INTEGER(mpl), PARAMETER :: two = 2 - INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: tempArr - SAVE - ! ... - finalUpdate=(globalParHeader(-3) == globalParHeader(-1)) - IF(finalUpdate) THEN ! final (cleanup) call - CALL sort2k(globalParLabelIndex,globalParHeader(-1)) ! sort items - END IF - ! save old LabelIndex - nused = globalParHeader(-1) - oldLength = globalParHeader(-0) - CALL mpalloc(tempArr,two,oldLength,'INONE: temp array') - tempArr(:,1:nused)=globalParLabelIndex(:,1:nused) - CALL mpdealloc(globalParLabelIndex) - CALL mpdealloc(globalParHashTable) - ! create new LabelIndex - newLength = globalParHeader(-3) - CALL mpalloc(globalParLabelIndex,two,newLength,'INONE: label & index') - CALL mpalloc(globalParHashTable,2*newLength,'INONE: hash pointer') - globalParHashTable = 0 - globalParLabelIndex(:,1:nused) = tempArr(:,1:nused) ! copy back saved content - CALL mpdealloc(tempArr) - globalParHeader(-0)=INT(newLength,mpi) ! length of labels/indices - globalParHeader(-3)=globalParHeader(-1) - globalParHeader(-4)=iprime(globalParHeader(-0)) ! prime number < LNDA - ! redefine hash - outer: DO i=1,globalParHeader(-1) - j=1+MOD(globalParLabelIndex(1,i),globalParHeader(-4))+globalParHeader(-0) - inner: DO - k=j - j=globalParHashTable(k) - IF(j == 0) EXIT inner ! unused hash code - IF(j == i) CYCLE outer ! found - ENDDO inner - globalParHashTable(k)=i - END DO outer - IF(.NOT.finalUpdate) RETURN - - globalParHeader(-2)=1 ! set flag to inhibit further updates - IF (lvllog > 1) THEN - WRITE(lunlog,*) ' ' - WRITE(lunlog,*) 'INONE: array reduced to',newLength,' words' - WRITE(lunlog,*) 'INONE:',globalParHeader(-1),' items stored.' - END IF -END SUBROUTINE upone ! update, redefine - -!> largest prime number < N. -!! -!! \param [in] n N -!! \return largest prime number < N - -INTEGER(mpi) FUNCTION iprime(n) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi), INTENT(IN) :: n - INTEGER(mpi) :: nprime - INTEGER(mpi) :: nsqrt - INTEGER(mpi) :: i - ! ... - SAVE - nprime=n ! max number - IF(MOD(nprime,2) == 0) nprime=nprime+1 ! ... odd number - outer: DO - nprime=nprime-2 ! next lower odd number - nsqrt=INT(SQRT(REAL(nprime,mps)),mpi) - DO i=3,nsqrt,2 ! - IF(i*(nprime/i) == nprime) CYCLE outer ! test prime number - END DO - EXIT outer ! found - END DO outer - iprime=nprime -END FUNCTION iprime - -!> First data \ref sssec-loop1 "loop" (get global labels). -!! -!! Read all data files and add all labels to global labels table, -!! add labels from parameters, constraints and measurements (from text files). -!! -!! Define variable and fixed global parameters (depending on entries and pre-sigma). -!! -!! Iterate if records had been skipped due to too small read buffer size. -!! -SUBROUTINE loop1 - USE mpmod - USE mpdalc - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: idum - INTEGER(mpi) :: in - INTEGER(mpi) :: indab - INTEGER(mpi) :: itgbi - INTEGER(mpi) :: itgbl - INTEGER(mpi) :: ivgbi - INTEGER(mpi) :: j - INTEGER(mpi) :: mqi - INTEGER(mpi) :: nc31 - INTEGER(mpi) :: nr - INTEGER(mpi) :: nwrd - INTEGER(mpi) :: inone - REAL(mpd) :: param - REAL(mpd) :: presg - REAL(mpd) :: prewt - - INTEGER(mpl) :: length - SAVE - ! ... - WRITE(lunlog,*) ' ' - WRITE(lunlog,*) 'LOOP1: starting' - CALL mstart('LOOP1') - ! add labels from parameter, constraints, measurements ------------- - DO i=1, lenParameters - idum=inone(listParameters(i)%label) - END DO - DO i=1, lenPreSigmas - idum=inone(listPreSigmas(i)%label) - END DO - DO i=1, lenConstraints - idum=inone(listConstraints(i)%label) - END DO - DO i=1, lenMeasurements - idum=inone(listMeasurements(i)%label) - END DO - - IF(globalParHeader(-1) /= 0) THEN - WRITE(lunlog,*) 'LOOP1:',globalParHeader(-1), ' labels from txt data stored' - END IF - WRITE(lunlog,*) 'LOOP1: reading data files' - - DO - DO j=1,globalParHeader(-1) - globalParLabelIndex(2,j)=0 ! reset count - END DO - - ! read all data files and add all labels to global labels table ---- - - IF(mprint /= 0) THEN - WRITE(*,*) 'Read all binary data files:' - END IF - CALL hmpldf(1,'Number of words/record in binary file') - CALL hmpdef(8,0.0,60.0,'not_stored data per record') - ! define read buffer - nc31=ncache/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats - nwrd=nc31+1 - length=nwrd*mthrdr - CALL mpalloc(readBufferPointer,length,'read buffer, pointer') - nwrd=nc31*10+2+ndimbuf - length=nwrd*mthrdr - CALL mpalloc(readBufferDataI,length,'read buffer, integer') - CALL mpalloc(readBufferDataD,length,'read buffer, double') - ! to read (old) float binary files - length=(ndimbuf+2)*mthrdr - CALL mpalloc(readBufferDataF,length,'read buffer, float') - - DO - CALL peread(nr) ! read records - IF (skippedRecords == 0) CALL peprep(0) ! prepare records - IF(nr <= 0) EXIT ! end of data? - END DO - ! release read buffer - CALL mpdealloc(readBufferDataF) - CALL mpdealloc(readBufferDataD) - CALL mpdealloc(readBufferDataI) - CALL mpdealloc(readBufferPointer) - IF (skippedRecords == 0) THEN - EXIT - ELSE - WRITE(lunlog,*) 'LOOP1: reading data files again' - END IF - END DO - - IF(nhistp /= 0) THEN - CALL hmprnt(1) - CALL hmprnt(8) - END IF - CALL hmpwrt(1) - CALL hmpwrt(8) - ntgb = globalParHeader(-1) ! total number of labels/parameters - IF (ntgb == 0) THEN - CALL peend(21,'Aborted, no labels/parameters defined') - STOP 'LOOP1: no labels/parameters defined' - END IF - CALL upone ! finalize the global label table - WRITE(lunlog,*) 'LOOP1:',ntgb, & - ' is total number NTGB of labels/parameters' - ! histogram number of entries per label ---------------------------- - CALL hmpldf(2,'Number of entries per label') - DO j=1,ntgb - CALL hmplnt(2,globalParLabelIndex(2,j)) - END DO - IF(nhistp /= 0) CALL hmprnt(2) ! print histogram - CALL hmpwrt(2) ! write to his file - - ! three subarrays for all global parameters ------------------------ - length=ntgb - CALL mpalloc(globalParameter,length,'global parameters') - globalParameter=0.0_mpd - CALL mpalloc(globalParPreSigma,length,'pre-sigmas') ! presigmas - globalParPreSigma=0. - CALL mpalloc(globalParStart,length,'global parameters at start') - globalParStart=0. - CALL mpalloc(globalParCopy,length,'copy of global parameters') - CALL mpalloc(globalParCounts,length,'global parameter counts') - CALL mpalloc(globalParCons,length,'global parameter constraints') - globalParCons=0 - - DO i=1,lenParameters ! parameter start values - param=listParameters(i)%value - in=inone(listParameters(i)%label) - IF(in /= 0) THEN - globalParameter(in)=param - globalParStart(in)=param - ENDIF - END DO - - npresg=0 - DO i=1,lenPreSigmas ! pre-sigma values - presg=listPreSigmas(i)%value - in=inone(listPreSigmas(i)%label) - IF(in /= 0) THEN - IF(presg > 0.0) npresg=npresg+1 ! FIXME: check if enough 'entries'? - globalParPreSigma(in)=presg ! insert pre-sigma 0 or > 0 - END IF - END DO - WRITE(lunlog,*) 'LOOP1:',npresg,' is number of pre-sigmas' - WRITE(*,*) 'LOOP1:',npresg,' is number of pre-sigmas' - IF(npresg == 0) WRITE(*,*) 'Warning: no pre-sigmas defined' - - ! determine flag variable (active) or fixed (inactive) ------------- - - indab=0 - DO i=1,ntgb - globalParCounts(i) = globalParLabelIndex(2,i) - IF (globalParPreSigma(i) < 0.0) THEN - globalParLabelIndex(2,i)=-1 ! fixed (pre-sigma), not used in matrix (not active) - ELSE IF(globalParCounts(i) < mreqenf) THEN - globalParLabelIndex(2,i)=-2 ! fixed (entries cut), not used in matrix (not active) - ELSE - indab=indab+1 - globalParLabelIndex(2,i)=indab ! variable, used in matrix (active) - END IF - END DO - globalParHeader(-6)=indab ! counted variable - nvgb=indab ! nr of variable parameters - WRITE(lunlog,*) 'LOOP1:',nvgb, ' is number NVGB of variable parameters' - IF(iteren > mreqenf) CALL loop1i ! iterate entries cut - - ! translation table of length NVGB of total global indices --------- - length=nvgb - CALL mpalloc(globalParVarToTotal,length,'translation table var -> total') - indab=0 - DO i=1,ntgb - IF(globalParLabelIndex(2,i) > 0) THEN - indab=indab+1 - globalParVarToTotal(indab)=i - END IF - END DO - - ! regularization --------------------------------------------------- - CALL mpalloc(globalParPreWeight,length,'pre-sigmas weights') ! presigma weights - WRITE(*,112) ' Default pre-sigma =',regpre, & - ' (if no individual pre-sigma defined)' - WRITE(*,*) 'Pre-sigma factor is',regula - - IF(nregul == 0) THEN - WRITE(*,*) 'No regularization will be done' - ELSE - WRITE(*,*) 'Regularization will be done, using factor',regula - END IF -112 FORMAT(a,e9.2,a) - IF (nvgb <= 0) THEN - CALL peend(22,'Aborted, no variable global parameters') - STOP '... no variable global parameters' - ENDIF - - DO ivgbi=1,nvgb ! IVGBI = variable parameter index - itgbi=globalParVarToTotal(ivgbi) ! ITGBI = global parameter index - presg=globalParPreSigma(itgbi) ! get pre-sigma - prewt=0.0 ! pre-weight - IF(presg > 0.0) THEN - prewt=1.0/presg**2 ! 1/presigma^2 - ELSE IF(presg == 0.0.AND.regpre > 0.0) THEN - prewt=1.0/REAL(regpre**2,mpd) ! default 1/presigma^2 - END IF - globalParPreWeight(ivgbi)=regula*prewt ! weight = factor / presigma^2 - END DO - - ! WRITE(*,*) 'GlPa_index GlPa_label array1 array6' - DO i=1,ntgb - itgbl=globalParLabelIndex(1,i) - ivgbi=globalParLabelIndex(2,i) - IF(ivgbi > 0) THEN - ! WRITE(*,111) I,ITGBL,QM(IND1+I),QM(IND6+IVGBI) - ELSE - ! WRITE(*,111) I,ITGBL,QM(IND1+I) - END IF - END DO - ! 111 FORMAT(I5,I10,F10.5,E12.4) - WRITE(*,101) 'NTGB',ntgb,'total number of parameters' - WRITE(*,101) 'NVGB',nvgb,'number of variable parameters' - - ! print overview over important numbers ---------------------------- - - nrecal=nrec - IF(mprint /= 0) THEN - WRITE(*,*) ' ' - WRITE(*,101) ' NREC',nrec,'number of records' - IF (nrecd > 0) WRITE(*,101) ' NRECD',nrec,'number of records containing doubles' - WRITE(*,101) 'MREQENF',mreqenf,'required number of entries (from binary files)' - IF(iteren > mreqenf) & - WRITE(*,101) 'ITEREN',iteren,'iterate cut for parameters with less entries' - WRITE(*,101) 'MREQENA',mreqena,'required number of entries (from accepted fits)' - IF (mreqpe > 1) WRITE(*,101) & - 'MREQPE',mreqpe,'required number of pair entries' - IF (msngpe >= 1) WRITE(*,101) & - 'MSNGPE',msngpe,'max pair entries single prec. storage' - WRITE(*,101) 'NTGB',ntgb,'total number of parameters' - WRITE(*,101) 'NVGB',nvgb,'number of variable parameters' - IF(mprint > 1) THEN - WRITE(*,*) ' ' - WRITE(*,*) 'Global parameter labels:' - mqi=ntgb - IF(mqi <= 100) THEN - WRITE(*,*) (globalParLabelIndex(2,i),i=1,mqi) - ELSE - WRITE(*,*) (globalParLabelIndex(2,i),i=1,30) - WRITE(*,*) ' ...' - mqi=((mqi-20)/20)*20+1 - WRITE(*,*) (globalParLabelIndex(2,i),i=mqi,ntgb) - END IF - END IF - WRITE(*,*) ' ' - WRITE(*,*) ' ' - END IF - WRITE(8,*) ' ' - WRITE(8,101) ' NREC',nrec,'number of records' - IF (nrecd > 0) WRITE(8,101) ' NRECD',nrec,'number of records containing doubles' - WRITE(8,101) 'MREQENF',mreqenf,'required number of entries (from binary files)' - IF(iteren > mreqenf) & - WRITE(8,101) 'ITEREN',iteren,'iterate cut for parameters with less entries' - WRITE(8,101) 'MREQENA',mreqena,'required number of entries (from accepted fits)' - - WRITE(lunlog,*) 'LOOP1: ending' - WRITE(lunlog,*) ' ' - CALL mend - -101 FORMAT(1X,a8,' =',i10,' = ',a) -END SUBROUTINE loop1 - -!> Iteration of first data \ref sssec-loop1 "loop". -!! -!! Read all data files again skipping measurements with any parameter below the -!! entries cut to update the number of entries. -!! -!! Redefine variable and fixed global parameters (depending on updated entries). -!! -SUBROUTINE loop1i - USE mpmod - USE mpdalc - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ibuf - INTEGER(mpi) :: ij - INTEGER(mpi) :: indab - INTEGER(mpi) :: inder - INTEGER(mpi) :: isfrst - INTEGER(mpi) :: islast - INTEGER(mpi) :: ist - INTEGER(mpi) :: j - INTEGER(mpi) :: ja - INTEGER(mpi) :: jb - INTEGER(mpi) :: jsp - INTEGER(mpi) :: nc31 - INTEGER(mpi) :: nr - INTEGER(mpi) :: nlow - INTEGER(mpi) :: nst - INTEGER(mpi) :: nwrd - REAL(mpr8) :: glder - - INTEGER(mpl) :: length - INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: newCounter - SAVE - - isfrst(ibuf)=readBufferPointer(ibuf)+1 - islast(ibuf)=readBufferDataI(readBufferPointer(ibuf)) - inder(i)=readBufferDataI(i) - glder(i)=readBufferDataD(i) - ! ... - WRITE(lunlog,*) ' ' - WRITE(lunlog,*) 'LOOP1: iterating' - WRITE(*,*) ' ' - WRITE(*,*) 'LOOP1: iterating' - - length=ntgb - CALL mpalloc(newCounter,length,'new entries counter') - newCounter=0 - - ! define read buffer - nc31=ncache/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats - nwrd=nc31+1 - length=nwrd*mthrdr - CALL mpalloc(readBufferPointer,length,'read buffer, pointer') - nwrd=nc31*10+2+ndimbuf - length=nwrd*mthrdr - CALL mpalloc(readBufferDataI,length,'read buffer, integer') - CALL mpalloc(readBufferDataD,length,'read buffer, double') - ! to read (old) float binary files - length=(ndimbuf+2)*mthrdr - CALL mpalloc(readBufferDataF,length,'read buffer, float') - - DO - CALL peread(nr) ! read records - CALL peprep(1) ! prepare records - DO ibuf=1,numReadBuffer ! buffer for current record - ist=isfrst(ibuf) - nst=islast(ibuf) - nwrd=nst-ist+1 - DO ! loop over measurements - CALL isjajb(nst,ist,ja,jb,jsp) - IF(ja == 0.AND.jb == 0) EXIT - IF(ja /= 0) THEN - nlow=0 - DO j=1,ist-jb - ij=inder(jb+j) ! index of global parameter - ij=globalParLabelIndex(2,ij) ! change to variable parameter - IF(ij == -2) nlow=nlow+1 ! fixed by entries cut - END DO - IF(nlow == 0) THEN - DO j=1,ist-jb - ij=inder(jb+j) ! index of global parameter - newCounter(ij)=newCounter(ij)+1 ! count again - END DO - ENDIF - END IF - END DO - ! end-of-event - END DO - IF(nr <= 0) EXIT ! end of data? - END DO - - ! release read buffer - CALL mpdealloc(readBufferDataF) - CALL mpdealloc(readBufferDataD) - CALL mpdealloc(readBufferDataI) - CALL mpdealloc(readBufferPointer) - - indab=0 - DO i=1,ntgb - IF(globalParLabelIndex(2,i) > 0) THEN - IF(newCounter(i) >= mreqenf .OR. globalParCounts(i) >= iteren) THEN - indab=indab+1 - globalParLabelIndex(2,i)=indab ! variable, used in matrix (active) - ELSE - globalParLabelIndex(2,i)=-3 ! fixed (iterated entries cut), not used in matrix (not active) - END IF - END IF - END DO - globalParHeader(-6)=indab ! counted variable - nvgb=indab ! nr of variable parameters - WRITE(lunlog,*) 'LOOP1:',nvgb, ' is number NVGB of variable parameters' - CALL mpdealloc(newCounter) - -END SUBROUTINE loop1i - -!> Second data \ref sssec-loop2 "loop" (number of derivatives, global label pairs). -!! -!! Calculate maximum number of local, global derivatives and equations per record. -!! -!! For sparse storage count index pairs with bit (field) counters to construct sparsity -!! structure (row offsets, (compressed) column lists). -!! -!! Determine read/write cache splitting from average record values (length, global par. vector/matrix). -!! -!! Check constraints for rank deficit. - -SUBROUTINE loop2 - USE mpmod - USE mpdalc - - IMPLICIT NONE - REAL(mps) :: chin2 - REAL(mps) :: chin3 - REAL(mps) :: cpr - REAL(mps) :: fsum - REAL(mps) :: gbc - REAL(mps) :: gbu - REAL(mpr8) :: glder - INTEGER(mpi) :: i - INTEGER(mpi) :: ia - INTEGER(mpi) :: ib - INTEGER(mpi) :: ibuf - INTEGER(mpi) :: icgb - INTEGER(mpi) :: iext - INTEGER(mpi) :: ihis - INTEGER(mpi) :: ij - INTEGER(mpi) :: ijn - INTEGER(mpi) :: inder - INTEGER(mpi) :: ioff - INTEGER(mpi) :: iproc - INTEGER(mpi) :: irecmm - INTEGER(mpi) :: isfrst - INTEGER(mpi) :: islast - INTEGER(mpi) :: ist - INTEGER(mpi) :: itgbi - INTEGER(mpi) :: itgbij - INTEGER(mpi) :: itgbik - INTEGER(mpi) :: ivgbij - INTEGER(mpi) :: ivgbik - INTEGER(mpi) :: j - INTEGER(mpi) :: ja - INTEGER(mpi) :: jb - INTEGER(mpi) :: jext - INTEGER(mpi) :: jcgb - INTEGER(mpi) :: jsp - INTEGER(mpi) :: joff - INTEGER(mpi) :: k - INTEGER(mpi) :: kfile - INTEGER(mpi) :: l - INTEGER(mpi) :: label - INTEGER(mpi) :: lu - INTEGER(mpi) :: lun - INTEGER(mpi) :: maeqnf - INTEGER(mpi) :: naeqna - INTEGER(mpi) :: naeqnf - INTEGER(mpi) :: naeqng - INTEGER(mpi) :: nc31 - INTEGER(mpi) :: ncachd - INTEGER(mpi) :: ncachi - INTEGER(mpi) :: ncachr - INTEGER(mpi) :: nda - INTEGER(mpi) :: ndf - INTEGER(mpi) :: ndfmax - INTEGER(mpi) :: nfixed - INTEGER(mpi) :: nggd - INTEGER(mpi) :: nggi - INTEGER(mpi) :: nmatmo - INTEGER(mpi) :: noff - INTEGER(mpi) :: nr - INTEGER(mpi) :: nrecf - INTEGER(mpi) :: nrecmm - INTEGER(mpi) :: nst - INTEGER(mpi) :: nwrd - INTEGER(mpi) :: inone - INTEGER(mpi) :: inc - REAL(mps) :: wgh - REAL(mps) :: wolfc3 - REAL(mps) :: wrec - REAL(mps) :: chindl - - REAL(mpd)::dstat(3) - REAL(mpd)::rerr - INTEGER(mpl):: noff8 - INTEGER(mpl):: ndimbi - INTEGER(mpl):: ndimsa(4) - INTEGER(mpl):: ndgn - INTEGER(mpl):: matsiz(2) - INTEGER(mpl):: matwords - INTEGER(mpl):: length - INTEGER(mpl):: rows - INTEGER(mpl):: cols - INTEGER(mpl), PARAMETER :: two=2 - INTEGER(mpi) :: maxGlobalPar = 0 - INTEGER(mpi) :: maxLocalPar = 0 - INTEGER(mpi) :: maxEquations = 0 - - INTERFACE ! needed for assumed-shape dummy arguments - SUBROUTINE ndbits(ndims,ncmprs,nsparr,ihst) - USE mpdef - INTEGER(mpl), DIMENSION(4), INTENT(OUT) :: ndims - INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: ncmprs - INTEGER(mpl), DIMENSION(:,:), INTENT(OUT) :: nsparr - INTEGER(mpi), INTENT(IN) :: ihst - END SUBROUTINE ndbits - SUBROUTINE spbits(nsparr,nsparc,ncmprs) - USE mpdef - INTEGER(mpl), DIMENSION(:,:), INTENT(IN) :: nsparr - INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: nsparc - INTEGER(mpi), DIMENSION(:), INTENT(IN) :: ncmprs - END SUBROUTINE spbits - SUBROUTINE gpbmap(npair) - USE mpdef - INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: npair - END SUBROUTINE gpbmap - END INTERFACE - - SAVE - - !$ INTEGER(mpi) :: OMP_GET_THREAD_NUM - - isfrst(ibuf)=readBufferPointer(ibuf)+1 - islast(ibuf)=readBufferDataI(readBufferPointer(ibuf)) - inder(i)=readBufferDataI(i) - glder(i)=readBufferDataD(i) - ! ... - WRITE(lunlog,*) ' ' - WRITE(lunlog,*) 'LOOP2: starting' - CALL mstart('LOOP2') - - ! two subarrays to get the global parameter indices, used in an event - length=nvgb - CALL mpalloc(globalIndexUsage,length,'global index') - CALL mpalloc(backIndexUsage,length,'back index') - backIndexUsage=0 - - ! prepare constraints - determine number of constraints NCGB - ! - sort and split into blocks - CALL prpcon - - IF (icelim > 0) THEN ! elimination - nagb=nvgb ! total number of parameters - nfgb=nvgb-ncgb ! number of fit parameters - nprecond(1)=0 ! number of constraints for preconditioner - nprecond(2)=nfgb ! matrix size for preconditioner - ELSE ! Lagrange multipliers - nagb=nvgb+ncgb ! total number of parameters - nfgb=nagb ! number of fit parameters - nprecond(1)=ncgb ! number of constraints for preconditioner - nprecond(2)=nvgb ! matrix size for preconditioner - ENDIF - noff8=int8(nagb)*int8(nagb-1)/2 - - ! read all data files and add all variable index pairs ------------- - - IF (icheck > 1) CALL clbmap(ntgb) - - IF(matsto == 2) THEN - CALL clbits(nagb,mreqpe,mhispe,msngpe,mcmprs,mextnd,ndimbi,nencdb,nspc) ! get dimension for bit storage, encoding, precision info - END IF - - IF (imonit /= 0) THEN - length=ntgb - CALL mpalloc(measIndex,length,'measurement counter/index') - measIndex=0 - CALL mpalloc(measRes,length,'measurement resolution') - measRes=0.0_mps - lunmon=9 - CALL mvopen(lunmon,'millepede.mon') - ENDIF - - ! reading events===reading events===reading events===reading events= - nrecf =0 ! records with fixed global parameters - naeqng=0 ! count number of equations (with global der.) - naeqnf=0 ! count number of equations ( " , fixed) - naeqna=0 ! all - WRITE(lunlog,*) 'LOOP2: start event reading' - ! monitoring for sparse matrix? - irecmm=0 - IF (matsto == 2.AND.matmon /= 0) THEN - nmatmo=0 - IF (matmon > 0) THEN - nrecmm=matmon - ELSE - nrecmm=1 - END IF - END IF - DO k=1,3 - dstat(k)=0.0_mpd - END DO - ! define read buffer - nc31=ncache/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats - nwrd=nc31+1 - length=nwrd*mthrdr - CALL mpalloc(readBufferPointer,length,'read buffer, pointer') - nwrd=nc31*10+2+ndimbuf - length=nwrd*mthrdr - CALL mpalloc(readBufferDataI,length,'read buffer, integer') - CALL mpalloc(readBufferDataD,length,'read buffer, real') - ! to read (old) float binary files - length=(ndimbuf+2)*mthrdr - CALL mpalloc(readBufferDataF,length,'read buffer, float') - - ! for checking appearance - IF (icheck > 1) THEN - length=5*ntgb - CALL mpalloc(appearanceCounter,length,'appearance statistics') - appearanceCounter=0 - length=ntgb - CALL mpalloc(pairCounter,length,'pair statistics') - pairCounter=0 - END IF - - DO - CALL peread(nr) ! read records - CALL peprep(1) ! prepare records - ioff=0 - DO ibuf=1,numReadBuffer ! buffer for current record - nrec=readBufferDataI(isfrst(ibuf)-2) ! record - ! Printout for DEBUG - IF(nrec <= mdebug) THEN - nda=0 - kfile=NINT(readBufferDataD(isfrst(ibuf)-1),mpi) ! file - wrec =REAL(readBufferDataD(isfrst(ibuf)-2),mps) ! weight - WRITE(*,*) ' ' - WRITE(*,*) 'Record number ',nrec,' from file ',kfile - IF (wgh /= 1.0) WRITE(*,*) ' weight ',wrec - ist=isfrst(ibuf) - nst=islast(ibuf) - DO ! loop over measurements - CALL isjajb(nst,ist,ja,jb,jsp) - IF(ja == 0) EXIT - nda=nda+1 - IF(nda > mdebg2) THEN - IF(nda == mdebg2+1) WRITE(*,*) '... and more data' - CYCLE - END IF - WRITE(*,*) ' ' - WRITE(*,*) nda, ' Measured value =',glder(ja),' +- ',glder(jb) - WRITE(*,*) 'Local derivatives:' - WRITE(*,107) (inder(ja+j),glder(ja+j),j=1,jb-ja-1) -107 FORMAT(6(i3,g12.4)) - IF (jb < ist) THEN - WRITE(*,*) 'Global derivatives:' - WRITE(*,108) (globalParLabelIndex(1,inder(jb+j)),inder(jb+j), & - globalParLabelIndex(2,inder(jb+j)),glder(jb+j),j=1,ist-jb) -108 FORMAT(3I11,g12.4) - END IF - IF(nda == 1) THEN - WRITE(*,*) 'total_par_label __label__ var_par_index derivative' - END IF - END DO - WRITE(*,*) ' ' - END IF - - nagbn =0 ! count number of global derivatives - nalcn =0 ! count number of local derivatives - naeqn =0 ! count number of equations - maeqnf=naeqnf - ist=isfrst(ibuf) - nst=islast(ibuf) - nwrd=nst-ist+1 - DO ! loop over measurements - CALL isjajb(nst,ist,ja,jb,jsp) - IF(ja == 0.AND.jb == 0) EXIT - naeqn=naeqn+1 - naeqna=naeqna+1 - IF(ja /= 0) THEN - IF (ist > jb) THEN - naeqng=naeqng+1 - ! monitoring, group measurements, sum up entries and errors - IF (imonit /= 0) THEN - rerr =REAL(glder(jb),mpd) ! the error - ij=inder(jb+1) ! index of first global parameter, used to group measurements - measIndex(ij)=measIndex(ij)+1 - measRes(ij)=measRes(ij)+rerr - END IF - END IF - nfixed=0 - DO j=1,ist-jb - ij=inder(jb+j) ! index of global parameter - ! check appearance - IF (icheck > 1) THEN - joff = 5*(ij-1) - kfile=NINT(readBufferDataD(isfrst(ibuf)-1),mpi) ! file - IF (appearanceCounter(joff+1) == 0) THEN - appearanceCounter(joff+1) = kfile - appearanceCounter(joff+2) = nrec-ifd(kfile) ! (local) record number - END IF - IF (appearanceCounter(joff+3) /= kfile) appearanceCounter(joff+5)=appearanceCounter(joff+5)+1 - appearanceCounter(joff+3) = kfile - appearanceCounter(joff+4) = nrec-ifd(kfile) ! (local) record number - ! count pairs - DO k=1,j - CALL inbmap(ij,inder(jb+k)) - END DO - END IF - - ij=globalParLabelIndex(2,ij) ! change to variable parameter - IF(ij > 0) THEN - ijn=backIndexUsage(ij) ! get index of index - IF(ijn == 0) THEN ! not yet included - nagbn=nagbn+1 ! count - globalIndexUsage(nagbn)=ij ! store variable index - backIndexUsage(ij)=nagbn ! store back index - END IF - ELSE - nfixed=nfixed+1 - END IF - END DO - IF (nfixed > 0) naeqnf=naeqnf+1 - END IF - - IF(ja /= 0.AND.jb /= 0) THEN - DO j=1,jb-ja-1 ! local parameters - ij=inder(ja+j) - nalcn=MAX(nalcn,ij) - END DO - END IF - END DO - - ! end-of-event - IF (naeqnf > maeqnf) nrecf=nrecf+1 - irecmm=irecmm+1 - ! end-of-event-end-of-event-end-of-event-end-of-event-end-of-event-e - - maxGlobalPar=MAX(nagbn,maxGlobalPar) ! maximum number of global parameters - maxLocalPar=MAX(nalcn,maxLocalPar) ! maximum number of local parameters - maxEquations=MAX(naeqn,maxEquations) ! maximum number of equations - - ! sample statistics for caching - dstat(1)=dstat(1)+REAL((nwrd+2)*2,mpd) ! record size - dstat(2)=dstat(2)+REAL(nagbn+2,mpd) ! indices, - dstat(3)=dstat(3)+REAL(nagbn*nagbn+nagbn,mpd) ! data for MUPDAT - - CALL sort1k(globalIndexUsage,nagbn) ! sort global par. - ! overwrite read buffer with lists of global labels - ioff=ioff+1 - readBufferPointer(ibuf)=ioff - readBufferDataI(ioff)=ioff+nagbn - DO i=1,nagbn ! reset global index array - iext=globalIndexUsage(i) - backIndexUsage(iext)=0 - readBufferDataI(ioff+i)=iext - END DO - ioff=ioff+nagbn - - END DO - ioff=0 - - IF (matsto == 2) THEN - !$OMP PARALLEL & - !$OMP DEFAULT(PRIVATE) & - !$OMP SHARED(numReadBuffer,readBufferPointer,readBufferDataI,MTHRD) - iproc=0 - !$ IPROC=OMP_GET_THREAD_NUM() ! thread number - DO ibuf=1,numReadBuffer - ist=isfrst(ibuf) - nst=islast(ibuf) - DO i=ist,nst ! store all combinations - iext=readBufferDataI(i) ! variable global index - !$ IF (MOD(IEXT,MTHRD).EQ.IPROC) THEN ! distinct rows per thread - DO l=ist,i - jext=readBufferDataI(l) - CALL inbits(iext,jext,1) ! save space - END DO - !$ ENDIF - END DO - END DO - !$OMP END PARALLEL - ! monitoring - IF (matmon /= 0.AND. & - (irecmm >= nrecmm.OR.irecmm == mxrec)) THEN - IF (nmatmo == 0) THEN - WRITE(*,*) - WRITE(*,*) 'Monitoring of sparse matrix construction' - WRITE(*,*) ' records ........ off-diagonal elements ', & - '....... compression memory' - WRITE(*,*) ' non-zero used(double) used', & - '(float) [%] [GB]' - END IF - nmatmo=nmatmo+1 - CALL ckbits(ndimsa) - gbc=1.0E-9*REAL((mpi*ndimsa(2)+mpd*ndimsa(3)+mps*ndimsa(4))/mpi*(BIT_SIZE(1_mpi)/8),mps) ! GB compressed - gbu=1.0E-9*REAL(((mpi+mpd)*(ndimsa(3)+ndimsa(4)))/mpi*(BIT_SIZE(1_mpi)/8),mps) ! GB uncompressed - cpr=100.0*gbc/gbu - WRITE(*,1177) irecmm,ndimsa(1),ndimsa(3),ndimsa(4),cpr,gbc -1177 FORMAT(i9,3I13,f10.2,f11.6) - DO WHILE(irecmm >= nrecmm) - IF (matmon > 0) THEN - nrecmm=nrecmm+matmon - ELSE - nrecmm=nrecmm*2 - END IF - END DO - END IF - - END IF - - IF (nr <= 0) EXIT ! next block of events ? - END DO - ! release read buffer - CALL mpdealloc(readBufferDataF) - CALL mpdealloc(readBufferDataD) - CALL mpdealloc(readBufferDataI) - CALL mpdealloc(readBufferPointer) - - WRITE(lunlog,*) 'LOOP2: event reading ended - end of data' - DO k=1,3 - dstat(k)=dstat(k)/REAL(nrec,mpd) - END DO - ! end=of=data=end=of=data=end=of=data=end=of=data=end=of=data=end=of - - IF (icheck > 1) THEN - CALL gpbmap(pairCounter) - END IF - - IF(matsto == 2) THEN - - ! constraints and index pairs with Lagrange multiplier - - - ! constraints - determine number of constraints NCGB and index-pairs - ! Lagrange multiplier and global parameters - - - inc=MAX(mreqpe, msngpe+1) ! keep constraints in double precision - - ! loop over (sorted) constraints - DO jcgb=1,ncgb - icgb=matConsSort(3,jcgb) ! unsorted constraint index - DO i=vecConsStart(icgb)+2,vecConsStart(icgb+1)-1 - label=listConstraints(i)%label - itgbi=inone(label) - ij=globalParLabelIndex(2,itgbi) ! change to variable parameter - IF(ij > 0 .AND. nagb > nvgb) THEN - CALL inbits(nvgb+jcgb,ij,inc) - END IF - END DO - END DO - - ! measurements - determine index-pairs - - - i=1 - DO WHILE (i <= lenMeasurements) - i=i+2 - ! loop over label/factor pairs - ia=i - DO - i=i+1 - IF(i > lenMeasurements) EXIT - IF(listMeasurements(i)%label == 0) EXIT - END DO - ib=i-1 - - DO j=ia,ib - itgbij=inone(listMeasurements(j)%label) ! total parameter index - ! first index - ivgbij=0 - IF(itgbij /= 0) ivgbij=globalParLabelIndex(2,itgbij) ! variable-parameter index - DO k=ia,j - itgbik=inone(listMeasurements(k)%label) ! total parameter index - ! second index - ivgbik=0 - IF(itgbik /= 0) ivgbik=globalParLabelIndex(2,itgbik) ! variable-parameter index - IF(ivgbij > 0.AND.ivgbik > 0) THEN - CALL inbits(ivgbij,ivgbik,mreqpe) - IF (mprint > 1) WRITE(*,*) 'add index pair ',ivgbij,ivgbik - END IF - END DO - END DO - - END DO - END IF - - numMeas=0 ! number of measurement groups - IF (imonit /= 0) THEN - DO i=1,ntgb - IF (measIndex(i) > 0) THEN - numMeas=numMeas+1 - measRes(i) = measRes(i)/REAL(measIndex(i),mpd) - measIndex(i) = numMeas - END IF - END DO - length=numMeas*mthrd*measBins - CALL mpalloc(measHists,length,'measurement counter') - END IF - ! print numbers ---------------------------------------------------- - - IF (nagb >= 65536) THEN - noff=INT(noff8/1000,mpi) - ELSE - noff=INT(noff8,mpi) - END IF - ndgn=0 - matwords=0 - IF(matsto == 2) THEN - ihis=0 - IF (mhispe > 0) THEN - ihis=15 - CALL hmpdef(ihis,0.0,REAL(mhispe,mps), 'NDBITS: #off-diagonal elements') - END IF - length=nagb*nspc - CALL mpalloc(sparseMatrixCompression,length, 'sparse matrix row compression') - sparseMatrixCompression=0 - length=(nagb+1)*nspc - CALL mpalloc(sparseMatrixOffsets,two,length, 'sparse matrix row offsets') - CALL ndbits(ndimsa,sparseMatrixCompression,sparseMatrixOffsets,ihis) - ndgn=ndimsa(3)+ndimsa(4) ! actual number of off-diagonal elements - matwords=ndimsa(2)+length ! size of sparsity structure - - IF (mhispe > 0) THEN - IF (nhistp /= 0) CALL hmprnt(ihis) - CALL hmpwrt(ihis) - END IF - END IF - - nagbn=maxGlobalPar ! max number of global parameters in one event - nalcn=maxLocalPar ! max number of local parameters in one event - naeqn=maxEquations ! max number of equations in one event - CALL mpdealloc(globalIndexUsage) - CALL mpdealloc(backIndexUsage) - ! matrices for event matrices - ! split up cache - IF (fcache(2) == 0.0) THEN ! from data (DSTAT) - fcache(1)=REAL(dstat(1),mps)*fcache(1) ! leave some part free for fluctuations - fcache(2)=REAL(dstat(2),mps) - fcache(3)=REAL(dstat(3),mps) - END IF - fsum=fcache(1)+fcache(2)+fcache(3) - DO k=1,3 - fcache(k)=fcache(k)/fsum - END DO - ncachr=NINT(REAL(ncache,mps)*fcache(1),mpi) ! read cache - ! define read buffer - nc31=ncachr/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats - nwrd=nc31+1 - length=nwrd*mthrdr - CALL mpalloc(readBufferPointer,length,'read buffer, pointer') - nwrd=nc31*10+2+ndimbuf - length=nwrd*mthrdr - CALL mpalloc(readBufferDataI,length,'read buffer, integer') - CALL mpalloc(readBufferDataD,length,'read buffer, real') - ! to read (old) float binary files - length=(ndimbuf+2)*mthrdr - CALL mpalloc(readBufferDataF,length,'read buffer, float') - - ncachi=NINT(REAL(ncache,mps)*fcache(2),mpi) ! index cache - ncachd=ncache-ncachr-ncachi ! data cache - nggd=(nagbn*nagbn+nagbn)/2+ncachd/(2*mthrd) ! number of double - nggi=2+nagbn+ncachi/mthrd ! number of ints - length=nagbn*mthrd - CALL mpalloc(globalIndexUsage,length, 'global parameters (dim =max/event)') - length=nvgb*mthrd - CALL mpalloc(backIndexUsage,length,'global variable-index array') - backIndexUsage=0 - length=nagbn*nalcn - CALL mpalloc(localGlobalMatrix,length,'local/global matrix') - length=nggd*mthrd - CALL mpalloc(writeBufferUpdates,length,'symmetric update matrices') - writeBufferHeader(-1)=nggd ! number of words per thread - writeBufferHeader(-2)=(nagbn*nagbn+nagbn)/2 ! min free (double) words - length=nggi*mthrd - CALL mpalloc(writeBufferIndices,length,'symmetric update matrix indices') - rows=7; cols=mthrd - CALL mpalloc(writeBufferInfo,rows,cols,'write buffer status (I)') - rows=2; cols=mthrd - CALL mpalloc(writeBufferData,rows,cols,'write buffer status (F)') - writeBufferHeader(1)=nggi ! number of words per thread - writeBufferHeader(2)=nagbn+2 ! min free words - - ! print all relevant dimension parameters - - DO lu=6,8,2 ! unit 6 and 8 - - WRITE(*,*) ' ' - WRITE(lu,101) 'NTGB',ntgb,'total number of parameters' - WRITE(lu,102) '(all parameters, appearing in binary files)' - WRITE(lu,101) 'NVGB',nvgb,'number of variable parameters' - WRITE(lu,102) '(appearing in fit matrix/vectors)' - WRITE(lu,101) 'NAGB',nagb,'number of all parameters' - WRITE(lu,102) '(including Lagrange multiplier or reduced)' - WRITE(lu,101) 'NFGB',nfgb,'number of fit parameters' - WRITE(lu,101) 'MBANDW',mbandw,'band width of band matrix' - WRITE(lu,102) '(if =0, no band matrix)' - IF (nagb >= 65536) THEN - WRITE(lu,101) 'NOFF/K',noff,'max number of off-diagonal elements' - ELSE - WRITE(lu,101) 'NOFF',noff,'max number of off-diagonal elements' - END IF - IF(ndgn /= 0) THEN - IF (nagb >= 65536) THEN - WRITE(lu,101) 'NDGN/K',ndgn/1000,'actual number of off-diagonal elements' - ELSE - WRITE(lu,101) 'NDGN',ndgn,'actual number of off-diagonal elements' - ENDIF - ENDIF - WRITE(lu,101) 'NCGB',ncgb,'number of constraints' - WRITE(lu,101) 'NAGBN',nagbn,'max number of global parameters in an event' - WRITE(lu,101) 'NALCN',nalcn,'max number of local parameters in an event' - WRITE(lu,101) 'NAEQN',naeqn,'max number of equations in an event' - IF (mprint > 1) THEN - WRITE(lu,101) 'NAEQNA',naeqna,'number of equations' - WRITE(lu,101) 'NAEQNG',naeqng, & - 'number of equations with global derivatives' - WRITE(lu,101) 'NAEQNF',naeqnf, & - 'number of equations with fixed global derivatives' - WRITE(lu,101) 'NRECF',nrecf, & - 'number of records with fixed global derivatives' - END IF - IF (ncache > 0) THEN - WRITE(lu,101) 'NCACHE',ncache,'number of words for caching' - WRITE(lu,111) (fcache(k)*100.0,k=1,3) -111 FORMAT(22X,'cache splitting ',3(f6.1,' %')) - END IF - WRITE(lu,*) ' ' - - WRITE(lu,*) ' ' - WRITE(lu,*) 'Solution method and matrix-storage mode:' - IF(metsol == 1) THEN - WRITE(lu,*) ' METSOL = 1: matrix inversion' - ELSE IF(metsol == 2) THEN - WRITE(lu,*) ' METSOL = 2: diagonalization' - ELSE IF(metsol == 3) THEN - WRITE(lu,*) ' METSOL = 3: MINRES (rtol', mrestl,')' - ELSE IF(metsol == 4) THEN - WRITE(lu,*) ' METSOL = 4: MINRES-QLP (rtol', mrestl,')' - ELSE IF(metsol == 5) THEN - WRITE(lu,*) ' METSOL = 5: GMRES' - END IF - WRITE(lu,*) ' with',mitera,' iterations' - IF(matsto == 1) THEN - WRITE(lu,*) ' MATSTO = 1: symmetric matrix, ', '(n*n+n)/2 elements' - ELSE IF(matsto == 2) THEN - WRITE(lu,*) ' MATSTO = 2: sparse matrix' - END IF - IF(mextnd>0) WRITE(lu,*) ' with extended storage' - IF(dflim /= 0.0) THEN - WRITE(lu,103) 'Convergence assumed, if expected dF <',dflim - END IF - IF(ncgb > 0) THEN - IF(nfgb < nvgb) THEN - WRITE(lu,*) 'Constraints handled by elimination' - ELSE - WRITE(lu,*) 'Constraints handled by Lagrange multipliers' - ENDIF - END IF - - END DO ! print loop - - ! Wolfe conditions - - IF(0.0 < wolfc1.AND.wolfc1 < wolfc2.AND.wolfc2 < 1.0) GO TO 32 - IF(wolfc1 == 0.0) wolfc1=1.0E-4 - IF(wolfc2 == 0.0) wolfc2=0.9 - IF(0.0 < wolfc1.AND.wolfc1 < wolfc2.AND.wolfc2 < 1.0) GO TO 32 - IF(wolfc1 <= 0.0) wolfc1=1.0E-4 - IF(wolfc2 >= 1.0) wolfc2=0.9 - IF(wolfc1 > wolfc2) THEN ! exchange - wolfc3=wolfc1 - wolfc1=wolfc2 - wolfc2=wolfc3 - ELSE - wolfc1=1.0E-4 - wolfc2=0.9 - END IF - WRITE(*,105) wolfc1,wolfc2 - WRITE(lun,105) wolfc1,wolfc2 -105 FORMAT(' Constants C1, C2 for Wolfe conditions:',g12.4,', ',g12.4) - - ! prepare matrix and gradient storage ------------------------------ - !32 CONTINUE -32 matsiz(1)=int8(nagb)*int8(nagb+1)/2 ! number of words for double precision storage 'j' - matsiz(2)=0 ! number of words for single precision storage '.' - IF(matsto == 2) THEN ! sparse matrix - matsiz(1)=ndimsa(3)+nagb - matsiz(2)=ndimsa(4) - CALL mpalloc(sparseMatrixColumns,ndimsa(2),'sparse matrix column list') - CALL spbits(sparseMatrixOffsets,sparseMatrixColumns,sparseMatrixCompression) - END IF - matwords=matwords+matsiz(1)*2+matsiz(2) ! #words for matrix storage - - CALL feasma ! prepare constraint matrices - - CALL vmprep(matsiz) ! prepare matrix and gradient storage - WRITE(*,*) ' ' - IF (matwords < 250000) THEN - WRITE(*,*) 'Size of global matrix: < 1 MB' - ELSE - WRITE(*,*) 'Size of global matrix:',INT(REAL(matwords,mps)*4.0E-6,mpi),' MB' - ENDIF - ! print chi^2 cut tables - - ndfmax=naeqn-1 - WRITE(lunlog,*) ' ' - WRITE(lunlog,*) ' Cut values of Chi^2/Ndf and Chi2,' - WRITE(lunlog,*) ' corresponding to 2 and 3 standard deviations' - WRITE(lunlog,*) ' Ndf Chi^2/Ndf(2) Chi^2(2) ', & - ' Chi^2/Ndf(3) Chi^2(3)' - ndf=0 - DO - IF(ndf > naeqn) EXIT - IF(ndf < 10) THEN - ndf=ndf+1 - ELSE IF(ndf < 20) THEN - ndf=ndf+2 - ELSE IF(ndf < 100) THEN - ndf=ndf+5 - ELSE IF(ndf < 200) THEN - ndf=ndf+10 - ELSE - EXIT - END IF - chin2=chindl(2,ndf) - chin3=chindl(3,ndf) - WRITE(lunlog,106) ndf,chin2,chin2*REAL(ndf,mps),chin3, chin3*REAL(ndf,mps) - END DO - - WRITE(lunlog,*) 'LOOP2: ending' - WRITE(lunlog,*) ' ' - CALL mend -101 FORMAT(1X,a8,' =',i10,' = ',a) -102 FORMAT(22X,a) -103 FORMAT(1X,a,g12.4) -106 FORMAT(i6,2(3X,f9.3,f12.1,3X)) -END SUBROUTINE loop2 - -!> Monitor input residuals. -!! -!! Read all data files again to monitor input residuals -!! -SUBROUTINE monres - USE mpmod - USE mpdalc - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ij - INTEGER(mpi) :: imed - INTEGER(mpi) :: j - INTEGER(mpi) :: k - INTEGER(mpi) :: nent - INTEGER(mpi), DIMENSION(measBins) :: isuml ! location - INTEGER(mpi), DIMENSION(measBins) :: isums ! scale - REAL(mps) :: amed - REAL(mps) :: amad - - INTEGER(mpl) :: ioff - LOGICAL :: lfirst - SAVE - DATA lfirst /.TRUE./ - - ! combine data from threads - ioff=0 - DO i=2,mthrd - ioff=ioff+measBins*numMeas - DO j=1,measBins*numMeas - measHists(j)=measHists(j)+measHists(ioff+j) - END DO - END DO - - IF (lfirst) THEN - IF (imonmd == 0) THEN - WRITE(lunmon,'(A)') '*** Normalized residuals grouped by first global label (per local fit cycle) ***' - ELSE - WRITE(lunmon,'(A)') '*** Pulls grouped by first global label (per local fit cycle) ***' - ENDIF - WRITE(lunmon,'(A)') '! LFC Label Entries Median RMS(MAD) ' - lfirst=.false. - END IF - - ! analyze histograms - ioff=0 - DO i=1,ntgb - IF (measIndex(i) > 0) THEN - isuml=0 - ! sum up content - isuml(1)=measHists(ioff+1) - DO j=2,measBins - isuml(j)=isuml(j-1)+measHists(ioff+j) - END DO - nent=isuml(measBins) - ! get median (for location) - DO j=2,measBins - IF (2*isuml(j) > nent) EXIT - END DO - imed=j - amed=REAL(j,mps) - IF (isuml(j) > isuml(j-1)) amed=amed+REAL(nent-2*isuml(j-1),mps)/REAL(2*isuml(j)-2*isuml(j-1),mps) - amed=REAL(measBinSize,mps)*(amed-REAL(measBins/2,mps)) - ! sum up differences - isums = 0 - DO j=imed,measBins - k=j-imed+1 - isums(k)=isums(k)+measHists(ioff+j) - END DO - DO j=imed-1,1,-1 - k=imed-j - isums(k)=isums(k)+measHists(ioff+j) - END DO - DO j=2, measBins - isums(j)=isums(j)+isums(j-1) - END DO - ! get median (for scale) - DO j=2,measBins - IF (2*isums(j) > nent) EXIT - END DO - amad=REAL(j-1,mps) - IF (isums(j) > isums(j-1)) amad=amad+REAL(nent-2*isums(j-1),mps)/REAL(2*isums(j)-2*isums(j-1),mps) - amad=REAL(measBinSize,mps)*amad - ij=globalParLabelIndex(1,i) - WRITE(lunmon,110) nloopn, ij, nent, amed, amad*1.4826, REAL(measRes(i),mps) - ! - ioff=ioff+measBins - END IF - END DO - -110 FORMAT(i5,2i10,3G14.5) -END SUBROUTINE monres - - -!> Prepare storage for vectors and matrices. -!! -!! \param[in] msize number of words for storage of global matrix (double, single prec.) - -SUBROUTINE vmprep(msize) - USE mpmod - USE mpdalc - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ncon - ! - INTEGER(mpl), INTENT(IN) :: msize(2) - - INTEGER(mpl) :: length - SAVE - ! ... - ! Vector/matrix storage - length=nagb*mthrd - CALL mpalloc(globalVector,length,'rhs vector') ! double precision vector - CALL mpalloc(globalCounter,length,'rhs counter') ! integer vector - lenGlobalVec=nagb - length=naeqn - CALL mpalloc(localCorrections,length,'residual vector of one record') - length=nalcn*nalcn - CALL mpalloc(aux,length,' local fit scratch array: aux') - CALL mpalloc(vbnd,length,' local fit scratch array: vbnd') - CALL mpalloc(vbdr,length,' local fit scratch array: vbdr') - length=((nalcn+1)*nalcn)/2 - CALL mpalloc(clmat,length,' local fit matrix: clmat') - CALL mpalloc(vbk,length,' local fit scratch array: vbk') - length=nalcn - CALL mpalloc(blvec,length,' local fit vector: blvec') - CALL mpalloc(vzru,length,' local fit scratch array: vzru') - CALL mpalloc(scdiag,length,' local fit scratch array: scdiag') - CALL mpalloc(scflag,length,' local fit scratch array: scflag') - CALL mpalloc(ibandh,2*length,' local fit band width hist.: ibandh') - - CALL mpalloc(globalMatD,msize(1),'global matrix (D)' ) - CALL mpalloc(globalMatF,msize(2),'global matrix (F)') - - IF(metsol >= 3) THEN ! GMRES/MINRES algorithms - ! array space is: - ! variable-width band matrix or diagonal matrix for parameters - ! followed by rectangular matrix for constraints - ! followed by symmetric matrix for constraints - ncon=nagb-nvgb - IF(mbandw > 0) THEN ! variable-width band matrix - length=nagb - CALL mpalloc(indPreCond,length,'pointer-array variable-band matrix') - DO i=1,MIN(mbandw,nvgb) - indPreCond(i)=(i*i+i)/2 ! increasing number - END DO - DO i=MIN(mbandw,nvgb)+1,nvgb - indPreCond(i)=indPreCond(i-1)+mbandw ! fixed band width - END DO - DO i=nvgb+1,nagb ! reset - indPreCond(i)=0 - END DO - length=indPreCond(nvgb)+ncon*nvgb+(ncon*ncon+ncon)/2 - CALL mpalloc(matPreCond,length,'variable-band matrix') - ELSE ! default preconditioner - length=nvgb+ncon*nvgb+(ncon*ncon+ncon)/2 - CALL mpalloc(matPreCond,length,'default preconditioner matrix') - END IF - END IF - - - length=nagb - CALL mpalloc(globalCorrections,length,'corrections') ! double prec corrections - - CALL mpalloc(workspaceD,length,'auxiliary array (D1)') ! double aux 1 - CALL mpalloc(workspaceLinesearch,length,'auxiliary array (D2)') ! double aux 2 - CALL mpalloc(workspaceI, length,'auxiliary array (I)') ! int aux 1 - - IF(metsol == 1) THEN - CALL mpalloc(workspaceDiag,length,'diagonal of global matrix)') ! double aux 1 - ! CALL MEGARR('t D',2*NAGB,'auxiliary array') ! double aux 8 - END IF - - IF(metsol == 2) THEN - CALL mpalloc(workspaceDiag,length,'diagonal of global matrix') ! double aux 1 - CALL mpalloc(workspaceDiagonalization,length,'auxiliary array (D3)') ! double aux 3 - CALL mpalloc(workspaceEigenValues,length,'auxiliary array (D6)') ! double aux 6 - length=nagb*nagb - CALL mpalloc(workspaceEigenVectors,length,'(rotation) matrix U') ! rotation matrix - END IF - - IF(metsol >= 3) THEN - CALL mpalloc(vecXav,length,'vector X (AVPROD)') ! double aux 1 - CALL mpalloc(vecBav,length,'vector B (AVPROD)') ! double aux 1 - END IF - -END SUBROUTINE vmprep - -!> Solution by matrix inversion. -!! -!! Parallelized (SQMINL), solve A*x=b. - -SUBROUTINE minver - USE mpmod - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpl) :: ioff1 - INTEGER(mpi) :: j - INTEGER(mpi) :: lun - INTEGER(mpi) :: nrank - INTEGER(mpl) :: ii - EXTERNAL avprd0 - - SAVE - ! ... - lun=lunlog ! log file - IF(lunlog == 0) lunlog=6 - - ! save diagonal (for global correlation) - IF(icalcm == 1) THEN - DO i=1,nagb - ii=i - workspaceDiag(i)=globalMatD((ii*ii+ii)/2) ! save diagonal elements - END DO - ENDIF - - ! WRITE(*,*) 'MINVER ICALCM=',ICALCM - !use elimination for constraints ? - IF(nfgb < nvgb) THEN - IF(icalcm == 1) CALL qlssq(avprd0,globalMatD,.true.) ! Q^t*A*Q - ! solve L^t*y=d by backward substitution - CALL qlbsub(vecConsResiduals,vecConsSolution) - ! transform, reduce rhs - CALL qlmlq(globalCorrections,1,.true.) ! Q^t*b - ! correction from eliminated part - DO i=1,nfgb - ioff1=((nfgb+1)*nfgb)/2+i - DO j=1,ncgb - globalCorrections(i)=globalCorrections(i)-globalMatD(ioff1)*vecConsSolution(j) - ioff1=ioff1+nfgb+j - END DO - END DO - END IF - - IF(icalcm == 1) THEN - ! invert and solve - CALL sqminl(globalMatD, globalCorrections,nfgb,nrank, & - workspaceD,workspaceI) - IF(nfgb /= nrank) THEN - WRITE(*,*) 'Warning: the rank defect of the symmetric',nfgb, & - '-by-',nfgb,' matrix is ',nfgb-nrank,' (should be zero).' - WRITE(lun,*) 'Warning: the rank defect of the symmetric',nfgb, & - '-by-',nfgb,' matrix is ',nfgb-nrank,' (should be zero).' - IF (iforce == 0 .AND. isubit == 0) THEN - isubit=1 - WRITE(*,*) ' --> enforcing SUBITO mode' - WRITE(lun,*) ' --> enforcing SUBITO mode' - END IF - ELSE IF(ndefec == 0) THEN - WRITE(lun,*) 'No rank defect of the symmetric matrix' - END IF - ndefec=max(nfgb-nrank, ndefec) ! rank defect - - ELSE ! multiply gradient by inverse matrix - workspaceD(:nfgb)=globalCorrections(:nfgb) - CALL dbsvxl(globalMatD,workspaceD,globalCorrections,nfgb) - END IF - - !use elimination for constraints ? - IF(nfgb < nvgb) THEN - ! extend, transform back solution - globalCorrections(nfgb+1:nvgb)=vecConsSolution(1:ncgb) - CALL qlmlq(globalCorrections,1,.false.) ! Q*x - END IF - -END SUBROUTINE minver - -!> Solution by diagonalization. -SUBROUTINE mdiags - USE mpmod - - IMPLICIT NONE - REAL(mps) :: evalue - INTEGER(mpi) :: i - INTEGER(mpi) :: iast - INTEGER(mpi) :: idia - INTEGER(mpi) :: imin - INTEGER(mpl) :: ioff1 - INTEGER(mpi) :: j - INTEGER(mpi) :: lun - INTEGER(mpi) :: nmax - INTEGER(mpi) :: nmin - INTEGER(mpi) :: ntop - ! - INTEGER(mpl) :: ii - EXTERNAL avprd0 - - SAVE - ! ... - - lun=lunlog ! log file - IF(lunlog == 0) lun=6 - - ! save diagonal (for global correlation) - IF(icalcm == 1) THEN - DO i=1,nagb - ii=i - workspaceDiag(i)=globalMatD((ii*ii+ii)/2) ! save diagonal elements - END DO - ENDIF - - !use elimination for constraints ? - IF(nfgb < nvgb) THEN - IF(icalcm == 1) CALL qlssq(avprd0,globalMatD,.true.) ! Q^t*A*Q - ! solve L^t*y=d by backward substitution - CALL qlbsub(vecConsResiduals,vecConsSolution) - ! transform, reduce rhs - CALL qlmlq(globalCorrections,1,.true.) ! Q^t*b - ! correction from eliminated part - DO i=1,nfgb - ioff1=((nfgb+1)*nfgb)/2+i - DO j=1,ncgb - globalCorrections(i)=globalCorrections(i)-globalMatD(ioff1)*vecConsSolution(j) - ioff1=ioff1+nfgb+j - END DO - END DO - END IF - - IF(icalcm == 1) THEN - ! eigenvalues eigenvectors symm_input - workspaceEigenValues=0.0_mpd - CALL devrot(nfgb,workspaceEigenValues,workspaceEigenVectors,globalMatD, & - workspaceDiagonalization,workspaceI) - - ! histogram of positive eigenvalues - - nmax=INT(1.0+LOG10(REAL(workspaceEigenValues(1),mps)),mpi) ! > log of largest eigenvalue - imin=1 - DO i=nagb,1,-1 - IF(workspaceEigenValues(i) > 0.0_mpd) THEN - imin=i ! index of smallest pos. eigenvalue - EXIT - END IF - END DO - nmin=INT(LOG10(REAL(workspaceEigenValues(imin),mps)),mpi) ! log of smallest pos. eigenvalue - ntop=nmin+6 - DO WHILE(ntop < nmax) - ntop=ntop+3 - END DO - - CALL hmpdef(7,REAL(nmin,mps),REAL(ntop,mps), 'log10 of positive eigenvalues') - DO idia=1,nagb - IF(workspaceEigenValues(idia) > 0.0_mpd) THEN ! positive - evalue=LOG10(REAL(workspaceEigenValues(idia),mps)) - CALL hmpent(7,evalue) - END IF - END DO - IF(nhistp /= 0) CALL hmprnt(7) - CALL hmpwrt(7) - - iast=MAX(1,imin-60) - CALL gmpdef(3,2,'low-value end of eigenvalues') - DO i=iast,nagb - evalue=REAL(workspaceEigenValues(i),mps) - CALL gmpxy(3,REAL(i,mps),evalue) - END DO - IF(nhistp /= 0) CALL gmprnt(3) - CALL gmpwrt(3) - - DO i=1,nfgb - workspaceDiagonalization(i)=0.0_mpd - IF(workspaceEigenValues(i) /= 0.0_mpd) THEN - workspaceDiagonalization(i)=MAX(0.0_mpd,LOG10(ABS(workspaceEigenValues(i)))+3.0_mpd) - IF(workspaceEigenValues(i) < 0.0_mpd) workspaceDiagonalization(i)=-workspaceDiagonalization(i) - END IF - END DO - WRITE(lun,*) ' ' - WRITE(lun,*) 'The first (largest) eigenvalues ...' - WRITE(lun,102) (workspaceEigenValues(i),i=1,MIN(20,nagb)) - WRITE(lun,*) ' ' - WRITE(lun,*) 'The last eigenvalues ... up to',nvgb - WRITE(lun,102) (workspaceEigenValues(i),i=MAX(1,nvgb-19),nvgb) - WRITE(lun,*) ' ' - IF(nagb > nvgb) THEN - WRITE(lun,*) 'The eigenvalues from',nvgb+1,' to',nagb - WRITE(lun,102) (workspaceEigenValues(i),i=nvgb+1,nagb) - WRITE(lun,*) ' ' - ENDIF - WRITE(lun,*) 'Log10 + 3 of ',nagb,' eigenvalues in decreasing', ' order' - WRITE(lun,*) '(for Eigenvalue < 0.001 the value 0.0 is shown)' - WRITE(lun,101) (workspaceDiagonalization(i),i=1,nagb) - IF(workspaceDiagonalization(nfgb) < 0) WRITE(lun,*) 'Negative values are ', & - 'printed for negative eigenvalues' - CALL devsig(nfgb,workspaceEigenValues,workspaceEigenVectors,globalVector,workspaceDiagonalization) - WRITE(lun,*) ' ' - WRITE(lun,*) nvgb,' significances: insignificant if ', & - 'compatible with N(0,1)' - WRITE(lun,101) (workspaceDiagonalization(i),i=1,nvgb) - - -101 FORMAT(10F7.1) -102 FORMAT(5E14.6) - - END IF - - ! solution --------------------------------------------------------- - workspaceD(:nfgb)=globalCorrections(:nfgb) - ! eigenvalues eigenvectors - CALL devsol(nfgb,workspaceEigenValues,workspaceEigenVectors,workspaceD,globalCorrections,workspaceDiagonalization) - - !use elimination for constraints ? - IF(nfgb < nvgb) THEN - ! extend, transform back solution - globalCorrections(nfgb+1:nvgb)=vecConsSolution(1:ncgb) - CALL qlmlq(globalCorrections,1,.false.) ! Q*x - END IF - -END SUBROUTINE mdiags - -!> Covariance matrix for diagonalization (,correction of eigenvectors). -SUBROUTINE zdiags - USE mpmod - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpl) :: ioff1 - INTEGER(mpl) :: ioff2 - INTEGER(mpi) :: j - - ! eigenvalue eigenvectors cov.matrix - CALL devinv(nfgb,workspaceEigenValues,workspaceEigenVectors,globalMatD) ! inv - - !use elimination for constraints ? - IF(nfgb < nvgb) THEN - ! extend, transform eigenvectors - ioff1=nfgb*nfgb - ioff2=nfgb*nvgb - workspaceEigenVectors(ioff2+1:)=0.0_mpd - DO i=nfgb,1,-1 - ioff1=ioff1-nfgb - ioff2=ioff2-nvgb - DO j=nfgb,1,-1 - workspaceEigenVectors(ioff2+j)=workspaceEigenVectors(ioff1+j) - END DO - workspaceEigenVectors(ioff2+nfgb+1:ioff2+nvgb)=0.0_mpd - END DO - CALL qlmlq(workspaceEigenVectors,nvgb,.false.) ! Q*U - END IF - -END SUBROUTINE zdiags - -!> Solution with \ref minresmodule::minres "MINRES". -!! -!! Solve A*x=b by minimizing |A*x-b| iteratively. Parallelized (AVPROD). -!! -!! Use preconditioner with zero (precon) or finite (equdec) band width. - -SUBROUTINE mminrs - USE mpmod - USE minresModule, ONLY: minres - - IMPLICIT NONE - INTEGER(mpi) :: istop - INTEGER(mpi) :: itn - INTEGER(mpi) :: itnlim - INTEGER(mpi) :: lun - INTEGER(mpi) :: nout - INTEGER(mpi) :: nrkd - INTEGER(mpi) :: nrkd2 - - REAL(mpd) :: shift - REAL(mpd) :: rtol - REAL(mpd) :: anorm - REAL(mpd) :: acond - REAL(mpd) :: arnorm - REAL(mpd) :: rnorm - REAL(mpd) :: ynorm - LOGICAL :: checka - EXTERNAL avprd0, avprod, mvsolv, mcsolv - SAVE - ! ... - lun=lunlog ! log file - IF(lunlog == 0) lun=6 - - nout=lun - itnlim=2000 ! iteration limit - shift =0.0_mpd ! not used - rtol = mrestl ! from steering - checka=.FALSE. - - workspaceD = globalCorrections - !use elimination for constraints ? - IF(nfgb < nvgb) THEN - ! solve L^t*y=d by backward substitution - CALL qlbsub(vecConsResiduals,vecConsSolution) - ! input to AVPRD0 - vecXav(1:nfgb)=0.0_mpd - vecXav(nfgb+1:nagb)=vecConsSolution - CALL qlmlq(vecXav,1,.false.) ! Q*x - ! calclulate vecBav=globalMat*vecXav - CALL AVPRD0(nagb,vecXav,vecBav) - ! correction from eliminated part - workspaceD=workspaceD-vecBav - ! transform, reduce rhs - CALL qlmlq(workspaceD,1,.true.) ! Q^t*b - END IF - - IF(mbandw == 0) THEN ! default preconditioner - IF(icalcm == 1) THEN - IF(nfgb < nvgb) CALL qlpssq(avprd0,matPreCond,1,.true.) ! transform preconditioner matrix - CALL precon(nprecond(1),nprecond(2),matPreCond,matPreCond, matPreCond(1+nvgb), & - matPreCond(1+nvgb+ncgb*nvgb),nrkd) - END IF - CALL minres(nfgb, avprod, mcsolv, workspaceD, shift, checka ,.TRUE. , & - globalCorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm) - ELSE IF(mbandw > 0) THEN ! band matrix preconditioner - IF(icalcm == 1) THEN - IF(nfgb < nvgb) CALL qlpssq(avprd0,matPreCond,mbandw,.true.) ! transform preconditioner matrix - WRITE(lun,*) 'MMINRS: EQUDEC started', nprecond(2), nprecond(1) - CALL equdec(nprecond(2),nprecond(1),lprecm,matPreCond,indPreCond,nrkd,nrkd2) - WRITE(lun,*) 'MMINRS: EQUDEC ended ', nrkd, nrkd2 - END IF - CALL minres(nfgb, avprod, mvsolv, workspaceD, shift, checka ,.TRUE. , & - globalCorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm) - ELSE - CALL minres(nfgb, avprod, mvsolv, workspaceD, shift, checka ,.FALSE. , & - globalCorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm) - END IF - - !use elimination for constraints ? - IF(nfgb < nvgb) THEN - ! extend, transform back solution - globalCorrections(nfgb+1:nvgb)=vecConsSolution(1:ncgb) - CALL qlmlq(globalCorrections,1,.false.) ! Q*x - END IF - - iitera=itn - istopa=istop - mnrsit=mnrsit+itn - - IF (istopa == 0) PRINT *, 'MINRES: istop=0, exact solution x=0.' - -END SUBROUTINE mminrs - -!> Solution with \ref minresqlpmodule::minresqlp "MINRES-QLP". -!! -!! Solve A*x=b by minimizing |A*x-b| iteratively. Parallelized (AVPROD). -!! -!! Use preconditioner with zero (precon) or finite (equdec) band width. - -SUBROUTINE mminrsqlp - USE mpmod - USE minresqlpModule, ONLY: minresqlp - - IMPLICIT NONE - INTEGER(mpi) :: istop - INTEGER(mpi) :: itn - INTEGER(mpi) :: itnlim - INTEGER(mpi) :: lun - INTEGER(mpi) :: nout - INTEGER(mpi) :: nrkd - INTEGER(mpi) :: nrkd2 - - REAL(mpd) :: rtol - REAL(mpd) :: mxxnrm - REAL(mpd) :: trcond - - EXTERNAL avprd0, avprod, mvsolv, mcsolv - SAVE - ! ... - lun=lunlog ! log file - IF(lunlog == 0) lun=6 - - nout=lun - itnlim=2000 ! iteration limit - rtol = mrestl ! from steering - mxxnrm = REAL(nagb,mpd)/SQRT(epsilon(mxxnrm)) - IF(mrmode == 1) THEN - trcond = 1.0_mpd/epsilon(trcond) ! only QR - ELSE IF(mrmode == 2) THEN - trcond = 1.0_mpd ! only QLP - ELSE - trcond = mrtcnd ! QR followed by QLP - END IF - - workspaceD = globalCorrections - !use elimination for constraints ? - IF(nfgb < nvgb) THEN - ! solve L^t*y=d by backward substitution - CALL qlbsub(vecConsResiduals,vecConsSolution) - ! input to AVPRD0 - vecXav(1:nfgb)=0.0_mpd - vecXav(nfgb+1:nagb)=vecConsSolution - CALL qlmlq(vecXav,1,.false.) ! Q*x - ! calclulate vecBav=globalMat*vecXav - CALL AVPRD0(nagb,vecXav,vecBav) - ! correction from eliminated part - workspaceD=workspaceD-vecBav - ! transform, reduce rhs - CALL qlmlq(workspaceD,1,.true.) ! Q^t*b - END IF - - IF(mbandw == 0) THEN ! default preconditioner - IF(icalcm == 1) THEN - IF(nfgb < nvgb) CALL qlpssq(avprd0,matPreCond,1,.true.) ! transform preconditioner matrix - CALL precon(nprecond(1),nprecond(2),matPreCond,matPreCond, matPreCond(1+nvgb), & - matPreCond(1+nvgb+ncgb*nvgb),nrkd) - END IF - CALL minresqlp( n=nfgb, Aprod=avprod, b=workspaceD, Msolve=mcsolv, nout=nout, & - itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, & - x=globalCorrections, istop=istop, itn=itn) - ELSE IF(mbandw > 0) THEN ! band matrix preconditioner - IF(icalcm == 1) THEN - IF(nfgb < nvgb) CALL qlpssq(avprd0,matPreCond,mbandw,.true.) ! transform preconditioner matrix - WRITE(lun,*) 'MMINRS: EQUDEC started', nprecond(2), nprecond(1) - CALL equdec(nprecond(2),nprecond(1),lprecm,matPreCond,indPreCond,nrkd,nrkd2) - WRITE(lun,*) 'MMINRS: EQUDEC ended ', nrkd, nrkd2 - END IF - - CALL minresqlp( n=nfgb, Aprod=avprod, b=workspaceD, Msolve=mvsolv, nout=nout, & - itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, & - x=globalCorrections, istop=istop, itn=itn) - ELSE - CALL minresqlp( n=nfgb, Aprod=avprod, b=workspaceD, nout=nout, & - itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, & - x=globalCorrections, istop=istop, itn=itn) - END IF - - !use elimination for constraints ? - IF(nfgb < nvgb) THEN - ! extend, transform back solution - globalCorrections(nfgb+1:nvgb)=vecConsSolution(1:ncgb) - CALL qlmlq(globalCorrections,1,.false.) ! Q*x - END IF - - iitera=itn - istopa=istop - mnrsit=mnrsit+itn - - IF (istopa == 3) PRINT *, 'MINRES: istop=0, exact solution x=0.' - -END SUBROUTINE mminrsqlp - -!> Solution for zero band width preconditioner. -!! -!! Used by \ref minresmodule::minres "MINRES". -!! -!! \param[in] n size of vectors -!! \param [in] x rhs vector -!! \param [out] y result vector - -SUBROUTINE mcsolv(n,x,y) ! solve M*y = x - USE mpmod - - IMPLICIT NONE - INTEGER(mpi),INTENT(IN) :: n - REAL(mpd), INTENT(IN) :: x(n) - REAL(mpd), INTENT(OUT) :: y(n) - SAVE - ! ... - CALL presol(nprecond(1),nprecond(2),matPreCond,matPreCond(1+nvgb),matPreCond(1+nvgb+ncgb*nvgb),y,x) -END SUBROUTINE mcsolv - -!> Solution for finite band width preconditioner. -!! -!! Used by \ref minresmodule::minres "MINRES". -!! -!! \param[in] n size of vectors -!! \param [in] x rhs vector -!! \param [out] y result vector - -SUBROUTINE mvsolv(n,x,y) ! solve M*y = x - USE mpmod - - IMPLICIT NONE - - INTEGER(mpi), INTENT(IN) :: n - REAL(mpd), INTENT(IN) :: x(n) - REAL(mpd), INTENT(OUT) :: y(n) - - SAVE - ! ... - y=x ! copy to output vector - - CALL equslv(nprecond(2),nprecond(1),matPreCond,indPreCond,y) -END SUBROUTINE mvsolv - - - -!*********************************************************************** - -!> Standard solution algorithm. -!! -!! \ref sssec-solmetover "Iterative solution". -!! In current \ref par-iter "iteration" calculate: -!! -!! ICALCM = +1 Matrix, gradient, Function value & solution -!! ICALCM = 0 gradient, Function value -!! ICALCM = -1 solution -!! ICALCM = -2 end -!! -!! \ref sssec-glofit "Solution" is obtained by selected method and -!! improved by \ref par-linesearch "line search". - -SUBROUTINE xloopn ! - USE mpmod - - IMPLICIT NONE - REAL(mps) :: catio - REAL(mps) :: concu2 - REAL(mps) :: concut - REAL, DIMENSION(2) :: ta - INTEGER(mpi) :: i - INTEGER(mpi) :: iact - INTEGER(mpi) :: iagain - INTEGER(mpi) :: idx - INTEGER(mpi) :: info - INTEGER(mpl) :: ioff - INTEGER(mpi) :: itgbi - INTEGER(mpi) :: ivgbi - INTEGER(mpi) :: jcalcm - INTEGER(mpi) :: k - INTEGER(mpi) :: labelg - INTEGER(mpi) :: litera - INTEGER(mpi) :: lrej - INTEGER(mpi) :: lun - INTEGER(mpi) :: lunp - INTEGER(mpi) :: minf - INTEGER(mpi) :: mrati - INTEGER(mpi) :: nan - INTEGER(mpi) :: nfaci - INTEGER(mpi) :: nloopsol - INTEGER(mpi) :: nrati - INTEGER(mpi) :: nrej - INTEGER(mpi) :: nsol - INTEGER(mpi) :: inone - - REAL(mpd) :: stp - REAL(mpd) :: dratio - REAL(mpd) :: dwmean - REAL(mpd) :: db - REAL(mpd) :: db1 - REAL(mpd) :: db2 - REAL(mpd) :: dbdot - LOGICAL :: btest - LOGICAL :: warner - LOGICAL :: warners - LOGICAL :: warnerss - LOGICAL :: lsflag - CHARACTER (LEN=7) :: cratio - CHARACTER (LEN=7) :: cfacin - CHARACTER (LEN=7) :: crjrat - EXTERNAL avprd0 - SAVE - ! ... - - ! Printout of algorithm for solution and important parameters ------ - - lun=lunlog ! log file - IF(lunlog == 0) lunlog=6 - - DO lunp=6,lunlog,lunlog-6 - WRITE(lunp,*) ' ' - WRITE(lunp,*) 'Solution algorithm: ' - WRITE(lunp,121) '=================================================== ' - - IF(metsol == 1) THEN - WRITE(lunp,121) 'solution method:','matrix inversion' - ELSE IF(metsol == 2) THEN - WRITE(lunp,121) 'solution method:','diagonalization' - ELSE IF(metsol == 3) THEN - WRITE(lunp,121) 'solution method:', 'minres (Paige/Saunders)' - ELSE IF(metsol == 4) THEN - WRITE(lunp,121) 'solution method:', 'minres-qlp (Choi/Paige/Saunders)' - IF(mrmode == 1) THEN - WRITE(lunp,121) ' ', ' using QR factorization' ! only QR - ELSE IF(mrmode == 2) THEN - WRITE(lunp,121) ' ', ' using QLP factorization' ! only QLP - ELSE - WRITE(lunp,121) ' ', ' using QR and QLP factorization' ! QR followed by QLP - WRITE(lunp,123) 'transition condition', mrtcnd - END IF - ELSE IF(metsol == 5) THEN - WRITE(lunp,121) 'solution method:', & - 'gmres (generalized minimzation of residuals)' - END IF - WRITE(lunp,123) 'convergence limit at Delta F=',dflim - WRITE(lunp,122) 'maximum number of iterations=',mitera - matrit=MIN(matrit,mitera) - IF(matrit > 1) THEN - WRITE(lunp,122) 'matrix recalculation up to ',matrit, '. iteration' - END IF - IF(metsol >= 3) THEN - IF(matsto == 1) THEN - WRITE(lunp,121) 'matrix storage:','full' - ELSE IF(matsto == 2) THEN - WRITE(lunp,121) 'matrix storage:','sparse' - END IF - WRITE(lunp,122) 'pre-con band-width parameter=',mbandw - IF(mbandw == 0) THEN - WRITE(lunp,121) 'pre-conditioning:','default' - ELSE IF(mbandw < 0) THEN - WRITE(lunp,121) 'pre-conditioning:','none!' - ELSE IF(mbandw > 0) THEN - IF(lprecm > 0) THEN - WRITE(lunp,121) 'pre-conditioning=','skyline-matrix (rank preserving)' - ELSE - WRITE(lunp,121) 'pre-conditioning=','band-matrix' - ENDIF - END IF - END IF - IF(regpre == 0.0_mpd.AND.npresg == 0) THEN - WRITE(lunp,121) 'using pre-sigmas:','no' - ELSE - ! FIXME: NPRESG contains parameters that failed the 'entries' cut... - WRITE(lunp,124) 'pre-sigmas defined for', & - REAL(100*npresg,mps)/REAL(nvgb,mps),' % of variable parameters' - WRITE(lunp,123) 'default pre-sigma=',regpre - END IF - IF(nregul == 0) THEN - WRITE(lunp,121) 'regularization:','no' - ELSE - WRITE(lunp,121) 'regularization:','yes' - WRITE(lunp,123) 'regularization factor=',regula - END IF - - IF(chicut /= 0.0) THEN - WRITE(lunp,121) 'Chi square cut equiv 3 st.dev applied' - WRITE(lunp,123) '... in first iteration with factor',chicut - WRITE(lunp,123) '... in second iteration with factor',chirem - WRITE(lunp,121) ' (reduced by sqrt in next iterations)' - END IF - IF(iscerr > 0) THEN - WRITE(lunp,121) 'Scaling of measurement errors applied' - WRITE(lunp,123) '... factor for "global" measuements',dscerr(1) - WRITE(lunp,123) '... factor for "local" measuements',dscerr(2) - END IF - IF(lhuber /= 0) THEN - WRITE(lunp,122) 'Down-weighting of outliers in', lhuber,' iterations' - WRITE(lunp,123) 'Cut on downweight fraction',dwcut - END IF - - -121 FORMAT(1X,a40,3X,a) -122 FORMAT(1X,a40,3X,i0,a) -123 FORMAT(1X,a40,2X,e9.2) -124 FORMAT(1X,a40,3X,f5.1,a) - END DO - - ! initialization of iterations ------------------------------------- - - iitera=0 - nsol =0 ! counter for solutions - info =0 - lsinfo=0 - stp =0.0_mpd - stepl =REAL(stp,mps) - concut=1.0E-12 ! initial constraint accuracy - concu2=1.0E-06 ! constraint accuracy - icalcm=1 ! require matrix calculation - iterat=0 ! iteration counter - iterat=-1 - litera=-2 - nloopsol=0 ! (new) solution from this nloopn - nrej=0 ! reset number of rejects - IF(metsol == 1) THEN - wolfc2=0.5 ! not accurate - minf=1 - ELSE IF(metsol == 2) THEN - wolfc2=0.5 ! not acurate - minf=2 - ELSE IF(metsol == 3) THEN - wolfc2=0.1 ! accurate - minf=3 - ELSE IF(metsol == 4) THEN - wolfc2=0.1 ! accurate - minf=3 - ELSE IF(metsol == 5) THEN - wolfc2=0.1 ! accurate - minf=3 - END IF - - ! check initial feasibility of constraint equations ---------------- - - WRITE(*,*) ' ' - IF(nofeas == 0) THEN ! make parameter feasible - WRITE(lunlog,*) 'Checking feasibility of parameters:' - WRITE(*,*) 'Checking feasibility of parameters:' - CALL feasib(concut,iact) ! check feasibility - IF(iact /= 0) THEN ! done ... - WRITE(*,102) concut - WRITE(*,*) ' parameters are made feasible' - WRITE(lunlog,102) concut - WRITE(lunlog,*) ' parameters are made feasible' - ELSE ! ... was OK - WRITE(*,*) ' parameters are feasible (i.e. satisfy constraints)' - WRITE(lunlog,*) ' parameters are feasible (i.e. satisfy constraints)' - END IF - concut=concu2 ! cut for constraint check - END IF - iact=1 ! set flag for new data loop - nofeas=0 ! set check-feasibility flag - - WRITE(*,*) ' ' - WRITE(*,*)'Reading files and accumulating vectors/matrices ...' - WRITE(*,*) ' ' - - CALL etime(ta,rstart) - iterat=-1 - litera= 0 - jcalcm=-1 - iagain= 0 - - icalcm=1 - - ! Block 1: data loop with vector (and matrix) calculation ---------- - - DO - IF(iterat >= 0) THEN - lcalcm=jcalcm+3 ! mode (1..4) of last loop - IF(jcalcm+1 /= 0) THEN - IF(iterat == 0) THEN - CALL ploopa(6) ! header - CALL ploopb(6) - CALL ploopa(lunlog) ! iteration line - CALL ploopb(lunlog) - iterat=1 - CALL gmpxyd(1,REAL(nloopn,mps),REAL(fvalue,mps),0.5,0.) ! fcn-value graph (no Delta) - ELSE - IF(iterat /= litera) THEN - CALL ploopb(6) - ! CALL PLOOPA(LUNLOG) - CALL ploopb(lunlog) - litera=iterat - CALL gmpxyd(1,REAL(nloopn,mps),REAL(fvalue,mps),0.5,delfun) ! fcn-value (with expected) - IF(metsol == 3 .OR. metsol == 4) THEN ! extend to 4, i.e. GMRES? - CALL gmpxy(2,REAL(iterat,mps),REAL(iitera,mps)) ! MINRES iterations - END IF - ELSE - CALL ploopc(6) ! sub-iteration line - CALL ploopc(lunlog) - CALL gmpxyd(1,REAL(nloopn,mps),REAL(fvalue,mps),0.5,0.) ! fcn-value graph (no Delta) - END IF - END IF - ELSE - CALL ploopd(6) ! solution line - CALL ploopd(lunlog) - END IF - CALL etime(ta,rstart) - ! CHK - IF (IABS(jcalcm) <= 1) THEN - idx=jcalcm+4 - times(idx )=(times(idx )*times(idx+3)+deltim) /(times(idx+3)+1.0) - times(idx+3)= times(idx+3)+1.0 - END IF - END IF - jcalcm=icalcm - - IF(icalcm >= 0) THEN ! ICALCM = +1 & 0 - CALL loopn ! data loop - CALL addcst ! constraints - lrej=nrej - nrej=nrejec(0)+nrejec(1)+nrejec(2)+nrejec(3) ! total number of rejects - IF(3*nrej > nrecal) THEN - WRITE(*,*) ' ' - WRITE(*,*) 'Data rejected in previous loop: ' - WRITE(*,*) ' ', & - nrejec(0), ' (rank deficit/NaN) ',nrejec(1),' (Ndf=0) ', & - nrejec(2), ' (huge) ',nrejec(3),' (large)' - WRITE(*,*) 'Too many rejects (>33.3%) - stop' - CALL peend(26,'Aborted, too many rejects') - STOP - END IF - END IF - ! Block 2: new iteration with calculation of solution -------------- - - IF(ABS(icalcm) == 1) THEN ! ICALCM = +1 & -1 - DO i=1,nagb - globalCorrections(i)=globalVector(i) ! copy rhs - END DO - DO i=1,nvgb - itgbi=globalParVarToTotal(i) - workspaceLinesearch(i)=globalParameter(itgbi) ! copy X for line search - END DO - iterat=iterat+1 ! increase iteration count - IF(metsol == 1) THEN - CALL minver ! inversion - ELSE IF(metsol == 2) THEN - CALL mdiags ! diagonalization - ELSE IF(metsol == 3) THEN - CALL mminrs ! MINRES - ELSE IF(metsol == 4) THEN - CALL mminrsqlp ! MINRES-QLP - ELSE IF(metsol == 5) THEN - WRITE(*,*) '... reserved for GMRES (not yet!)' - CALL mminrs ! GMRES not yet - END IF - nloopsol=nloopn ! (new) solution for this nloopn - - ! check feasibility and evtl. make step vector feasible - - DO i=1,nvgb - itgbi=globalParVarToTotal(i) - globalParCopy(itgbi)=globalParameter(itgbi) ! save - globalParameter(itgbi)=globalParameter(itgbi)+globalCorrections(i) ! update - END DO - CALL feasib(concut,iact) ! improve constraints - concut=concu2 ! new cut for constraint check - DO i=1,nvgb - itgbi=globalParVarToTotal(i) - globalCorrections(i)=globalParameter(itgbi)-globalParCopy(itgbi) ! feasible stp - globalParameter(itgbi)=globalParCopy(itgbi) ! restore - END DO - - db=dbdot(nvgb,globalCorrections,globalVector) - db1=dbdot(nvgb,globalCorrections,globalCorrections) - db2=dbdot(nvgb,globalVector,globalVector) - delfun=REAL(db,mps) - angras=REAL(db/SQRT(db1*db2),mps) - - ! do line search for this iteration/solution ? - ! lsearch >2: all, =2: all with (next) chicut =1., =1: last, <1: none - lsflag=(lsearch > 2 .OR. (lsearch == 2 .AND. chicut < 2.25) .OR. & - (lsearch == 1 .AND. chicut < 2.25 .AND. (delfun <= dflim .OR. iterat >= mitera))) - IF (lsflag) THEN - ! initialize line search based on slopes and prepare next - CALL ptldef(wolfc2, 10.0, minf,10) - IF(metsol == 1) THEN - wolfc2=0.5 ! not accurate - minf=3 - ELSE IF(metsol == 2) THEN - wolfc2=0.5 ! not acurate - minf=3 - ELSE IF(metsol == 3) THEN - wolfc2=0.1 ! accurate - minf=4 - ELSE IF(metsol == 4) THEN - wolfc2=0.1 ! accurate - minf=4 - ELSE IF(metsol == 5) THEN - wolfc2=0.1 ! accurate - minf=4 - END IF - ENDIF - - ! change significantly negative ? - IF(db <= -16.0_mpd*SQRT(max(db1,db2))*epsilon(db)) THEN - WRITE(*,*) 'Function not decreasing:',db - IF(db > -1.0E-3_mpd) THEN ! 100311, VB/CK: allow some margin for numerics - iagain=iagain+1 - IF (iagain <= 1) THEN - WRITE(*,*) '... again matrix calculation' - icalcm=1 - CYCLE - ELSE - WRITE(*,*) '... aborting iterations' - GO TO 90 - END IF - ELSE - WRITE(*,*) '... stopping iterations' - iagain=-1 - GO TO 90 - END IF - ELSE - iagain=0 - END IF - icalcm=0 ! switch - ENDIF - ! Block 3: line searching ------------------------------------------ - - IF(icalcm+2 == 0) EXIT - IF (lsflag) THEN - CALL ptline(nvgb,workspaceLinesearch, & ! current parameter values - flines, & ! chi^2 function value - globalVector, & ! gradient - globalCorrections, & ! step vector stp - stp, & ! returned step factor - info) ! returned information - ! WRITE(*,*) 'PTLINE returns INFO, STP=',INFO, STP - ELSE ! skip line search - info=10 - stepl=1.0 - IF (nloopn == nloopsol) THEN ! new solution: update corrections - workspaceLinesearch=workspaceLinesearch+globalCorrections - ENDIF - ENDIF - lsinfo=info - - stepl=REAL(stp,mps) - nan=0 - DO i=1,nvgb - itgbi=globalParVarToTotal(i) - IF ((.NOT.(workspaceLinesearch(i) <= 0.0_mpd)).AND. & - (.NOT.(workspaceLinesearch(i) > 0.0_mpd))) nan=nan+1 - globalParameter(itgbi)=workspaceLinesearch(i) ! current parameter values - END DO - - IF (nan > 0) THEN - WRITE(*,*) 'Result vector containes ', nan,' NaNs - stop' - CALL peend(25,'Aborted, result vector contains NaNs') - STOP - END IF - - ! subito exit, if required ----------------------------------------- - - IF(isubit /= 0) THEN ! subito - WRITE(*,*) 'Subito! Exit after first step.' - GO TO 90 - END IF - - IF(info == 0) THEN - WRITE(*,*) 'INFO=0 should not happen (line search input err)' - IF (iagain <= 0) THEN - icalcm=1 - CYCLE - ENDIF - END IF - IF(info < 0 .OR. nloopn == nloopsol) CYCLE - ! Block 4: line search convergence --------------------------------- - - CALL ptlprt(lunlog) - CALL feasib(concut,iact) ! check constraints - IF(iact /= 0.OR.chicut > 1.0) THEN - icalcm=-1 - IF(iterat < matrit) icalcm=+1 - CYCLE ! iterate - END IF - IF(delfun <= dflim) GO TO 90 ! convergence - IF(iterat >= mitera) GO TO 90 ! ending - icalcm=-1 - IF(iterat < matrit) icalcm=+1 - CYCLE ! next iteration - - ! Block 5: iteration ending ---------------------------------------- - -90 icalcm=-2 - END DO - IF(nrejec(0)+nrejec(1)+nrejec(2)+nrejec(3) /= 0) THEN - WRITE(*,*) ' ' - WRITE(*,*) 'Data rejected in last loop: ' - WRITE(*,*) ' ', & - nrejec(0), ' (rank deficit/NaN) ',nrejec(1),' (Ndf=0) ', & - nrejec(2), ' (huge) ',nrejec(3),' (large)' - END IF - - ! monitoring of residuals - IF (imonit > 0 .AND. btest(imonit,1)) CALL monres - IF (lunmon > 0) CLOSE(UNIT=lunmon) - - dwmean=sumndf/REAL(ndfsum,mpd) - dratio=fvalue/dwmean/REAL(ndfsum-nfgb,mpd) - catio=REAL(dratio,mps) - IF(nloopn /= 1.AND.lhuber /= 0) THEN - catio=catio/0.9326 ! correction Huber downweighting (in global chi2) - END IF - mrati=nint(100.0*catio,mpi) - - DO lunp=6,lunlog,lunlog-6 - WRITE(lunp,*) ' ' - IF (nfilw <= 0) THEN - WRITE(lunp,*) 'Sum(Chi^2)/Sum(Ndf) =',fvalue - WRITE(lunp,*) ' / (',ndfsum,'-',nfgb,')' - WRITE(lunp,*) ' =',dratio - ELSE - WRITE(lunp,*) 'Sum(W*Chi^2)/Sum(Ndf)/ =',fvalue - WRITE(lunp,*) ' / (',ndfsum,'-', nfgb,')' - WRITE(lunp,*) ' /',dwmean - WRITE(lunp,*) ' =',dratio - END IF - WRITE(lunp,*) ' ' - IF(nloopn /= 1.AND.lhuber /= 0) WRITE(lunp,*) & - ' with correction for down-weighting ',catio - END DO - nrej=nrejec(0)+nrejec(1)+nrejec(2)+nrejec(3) ! total number of rejects - - ! ... the end with exit code ??????????????????????????????????????? - - ! WRITE(*,199) ! write exit code - ! + '-----------------------------------------------------------' - ! IF(ITEXIT.EQ.0) WRITE(*,199) - ! + 'Exit code = 0: Convergence reached' - ! IF(ITEXIT.EQ.1) WRITE(*,199) - ! + 'Exit code = 1: No improvement in last iteration' - ! IF(ITEXIT.EQ.2) WRITE(*,199) - ! + 'Exit code = 2: Maximum number of iterations reached' - ! IF(ITEXIT.EQ.3) WRITE(*,199) - ! + 'Exit code = 3: Failure' - ! WRITE(*,199) - ! + '-----------------------------------------------------------' - ! WRITE(*,199) ' ' - - - nrati=nint(10000.0*REAL(nrej,mps)/REAL(nrecal,mps),mpi) - WRITE(crjrat,197) 0.01_mpd*REAL(nrati,mpd) - nfaci=nint(100.0*SQRT(catio),mpi) - - WRITE(cratio,197) 0.01_mpd*REAL(mrati,mpd) - WRITE(cfacin,197) 0.01_mpd*REAL(nfaci,mpd) - - warner=.FALSE. ! warnings - IF(mrati < 90.OR.mrati > 110) warner=.TRUE. - IF(nrati > 100) warner=.TRUE. - IF(ncgbe /= 0) warner=.TRUE. - warners = .FALSE. ! severe warnings - IF(nalow /= 0) warners=.TRUE. - warnerss = .FALSE. ! more severe warnings - IF(nmiss1 /= 0) warnerss=.TRUE. - IF(iagain /= 0) warnerss=.TRUE. - IF(ndefec /= 0) warnerss=.TRUE. - - IF(warner.OR.warners.OR.warnerss) THEN - WRITE(*,199) ' ' - WRITE(*,199) ' ' - WRITE(*,199) 'WarningWarningWarningWarningWarningWarningWarningWarningWar' - WRITE(*,199) 'arningWarningWarningWarningWarningWarningWarningWarningWarn' - WRITE(*,199) 'rningWarningWarningWarningWarningWarningWarningWarningWarni' - WRITE(*,199) 'ningWarningWarningWarningWarningWarningWarningWarningWarnin' - WRITE(*,199) 'ingWarningWarningWarningWarningWarningWarningWarningWarning' - WRITE(*,199) 'ngWarningWarningWarningWarningWarningWarningWarningWarningW' - WRITE(*,199) 'gWarningWarningWarningWarningWarningWarningWarningWarningWa' - - IF(mrati < 90.OR.mrati > 110) THEN - WRITE(*,199) ' ' - WRITE(*,*) ' Chi^2/Ndf = ',cratio, ' (should be close to 1)' - WRITE(*,*) ' => multiply all input standard ', & - 'deviations by factor',cfacin - END IF - - IF(nrati > 100) THEN - WRITE(*,199) ' ' - WRITE(*,*) ' Fraction of rejects =',crjrat,' %', & - ' (should be far below 1 %)' - WRITE(*,*) ' => please provide correct mille data' - END IF - - IF(iagain /= 0) THEN - WRITE(*,199) ' ' - WRITE(*,*) ' Matrix not positiv definite '// & - '(function not decreasing)' - WRITE(*,*) ' => please provide correct mille data' - END IF - - IF(ndefec /= 0) THEN - WRITE(*,199) ' ' - WRITE(*,*) ' Rank defect =',ndefec, & - ' for global matrix, should be 0' - WRITE(*,*) ' => please provide correct mille data' - END IF - - IF(nmiss1 /= 0) THEN - WRITE(*,199) ' ' - WRITE(*,*) ' Rank defect =',nmiss1, & - ' for constraint equations, should be 0' - WRITE(*,*) ' => please correct constraint definition' - END IF - - IF(ncgbe /= 0) THEN - WRITE(*,199) ' ' - WRITE(*,*) ' Number of empty constraints =',ncgbe, ', should be 0' - WRITE(*,*) ' => please check constraint definition, mille data' - END IF - - IF(nalow /= 0) THEN - WRITE(*,199) ' ' - WRITE(*,*) ' Possible rank defects =',nalow, & - ' for global vector (too few entries)' - WRITE(*,*) ' => please check mille data and ENTRIES cut' - END IF - - WRITE(*,199) ' ' - WRITE(*,199) 'WarningWarningWarningWarningWarningWarningWarningWarningWar' - WRITE(*,199) 'arningWarningWarningWarningWarningWarningWarningWarningWarn' - WRITE(*,199) 'rningWarningWarningWarningWarningWarningWarningWarningWarni' - WRITE(*,199) 'ningWarningWarningWarningWarningWarningWarningWarningWarnin' - WRITE(*,199) 'ingWarningWarningWarningWarningWarningWarningWarningWarning' - WRITE(*,199) 'ngWarningWarningWarningWarningWarningWarningWarningWarningW' - WRITE(*,199) 'gWarningWarningWarningWarningWarningWarningWarningWarningWa' - WRITE(*,199) ' ' - - ENDIF - - CALL mend ! modul ending - - ! ------------------------------------------------------------------ - - IF(metsol == 1) THEN - - ELSE IF(metsol == 2) THEN - CALL zdiags - ELSE IF(metsol == 3 .OR. metsol == 4) THEN - ! errors and correlations from MINRES - DO k=1,mnrsel - labelg=lbmnrs(k) - IF(labelg == 0) CYCLE - itgbi=inone(labelg) - ivgbi=0 - IF(itgbi /= 0) ivgbi=globalParLabelIndex(2,itgbi) - IF(ivgbi < 0) ivgbi=0 - IF(ivgbi == 0) CYCLE - ! determine error and global correlation for parameter IVGBI - IF (metsol == 3) THEN - CALL solglo(ivgbi) - ELSE - CALL solgloqlp(ivgbi) - ENDIF - END DO - - ELSE IF(metsol == 5) THEN - - END IF - - IF(metsol <= 2) THEN ! inversion or diagonalization ? - !use elimination for constraints ? - IF(nfgb < nvgb) THEN - ! extend, transform matrix - DO i=nvgb-ncgb+1,nvgb - ioff=((i-1)*i)/2 - globalMatD(ioff+1:ioff+i)=0.0_mpd - END DO - CALL qlssq(avprd0,globalMatD,.false.) ! Q^t*A*Q - END IF - END IF - - CALL prtglo ! print result - - IF (warnerss) THEN - CALL peend(3,'Ended with severe warnings (bad global matrix)') - ELSE IF (warners) THEN - CALL peend(2,'Ended with severe warnings (insufficient measurements)') - ELSE IF (warner) THEN - CALL peend(1,'Ended with warnings (bad measurements)') - ELSE - CALL peend(0,'Ended normally') - END IF - -102 FORMAT(' Call FEASIB with cut=',g10.3) - ! 103 FORMAT(1X,A,G12.4) -197 FORMAT(F7.2) -199 FORMAT(7X,a) -END SUBROUTINE xloopn ! standard solution - -!> Interprete command line option, steering file. -!! -!! Fetch and interprete command line options, -!! if steering file specified, check file existence (calling NUFILE) -!! -!! If no steering file specified, check default steering file. -!! -!! Create test files for command line option '-t'. -!! -!! Read steering file, print some lines, detect names of text and -!! binary files, check file existence, store all file names. -!! -!! Open all binary files. - -SUBROUTINE filetc - USE mpmod - USE mpdalc - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ia - INTEGER(mpi) :: iargc - INTEGER(mpi) :: ib - INTEGER(mpi) :: ie - INTEGER(mpi) :: ierrf - INTEGER(mpi) :: ieq - INTEGER(mpi) :: ifilb - INTEGER(mpi) :: ioff - INTEGER(mpi) :: iopt - INTEGER(mpi) :: ios - INTEGER(mpi) :: iosum - INTEGER(mpi) :: it - INTEGER(mpi) :: k - INTEGER(mpi) :: mat - INTEGER(mpi) :: nab - INTEGER(mpi) :: nline - INTEGER(mpi) :: npat - INTEGER(mpi) :: ntext - INTEGER(mpi) :: nu - INTEGER(mpi) :: nuf - INTEGER(mpi) :: nums - INTEGER(mpi) :: nufile - INTEGER(mpi) :: lenfileInfo - INTEGER(mpi) :: lenFileNames - INTEGER(mpi) :: matint - INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: vecfileInfo - INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: tempArray - INTEGER(mpl) :: rows - INTEGER(mpl) :: cols - INTEGER(mpl) :: newcols - INTEGER(mpl) :: length - - CHARACTER (LEN=1024) :: text - CHARACTER (LEN=1024) :: fname - CHARACTER (LEN=14) :: bite(3) - CHARACTER (LEN=32) :: keystx - REAL(mpd) :: dnum(100) - SAVE - DATA bite/'C_binary','text ','Fortran_binary'/ - ! ... - CALL mstart('FILETC/X') - - nuf=1 ! C binary is default - DO i=1,8 - times(i)=0.0 - END DO - - ! read command line options ---------------------------------------- - - filnam=' ' ! print command line options and find steering file - DO i=1,iargc() - IF(i == 1) THEN - WRITE(*,*) ' ' - WRITE(*,*) 'Command line options: ' - WRITE(*,*) '--------------------- ' - END IF - CALL getarg(i,text) ! get I.th text from command line - CALL rltext(text,ia,ib,nab) ! return indices for non-blank area - WRITE(*,101) i,text(1:nab) ! echo print - IF(text(ia:ia) /= '-') THEN - nu=nufile(text(ia:ib)) ! inquire on file existence - IF(nu == 2) THEN ! existing text file - IF(filnam /= ' ') THEN - WRITE(*,*) 'Second text file in command line - stop' - CALL peend(12,'Aborted, second text file in command line') - STOP - ELSE - filnam=text - END IF - ELSE - WRITE(*,*) 'Open error for file:',text(ia:ib),' - stop' - CALL peend(16,'Aborted, open error for file') - STOP - END IF - ELSE - IF(INDEX(text(ia:ib),'b') /= 0) THEN - mdebug=3 ! debug flag - WRITE(*,*) 'Debugging requested' - END IF - it=INDEX(text(ia:ib),'t') - IF(it /= 0) THEN - ictest=1 ! internal test files - ieq=INDEX(text(ia+it:ib),'=')+it - IF (it /= ieq) THEN - IF (INDEX(text(ia+ieq:ib),'SL0' ) /= 0) ictest=2 - IF (INDEX(text(ia+ieq:ib),'SLE' ) /= 0) ictest=3 - IF (INDEX(text(ia+ieq:ib),'BP' ) /= 0) ictest=4 - IF (INDEX(text(ia+ieq:ib),'BRLF') /= 0) ictest=5 - IF (INDEX(text(ia+ieq:ib),'BRLC') /= 0) ictest=6 - END IF - END IF - IF(INDEX(text(ia:ib),'s') /= 0) isubit=1 ! like "subito" - IF(INDEX(text(ia:ib),'f') /= 0) iforce=1 ! like "force" - IF(INDEX(text(ia:ib),'c') /= 0) icheck=1 ! like "checkinput" - IF(INDEX(text(ia:ib),'C') /= 0) icheck=2 ! like "checkinput 2" - END IF - IF(i == iargc()) WRITE(*,*) '--------------------- ' - END DO - - - ! create test files for option -t ---------------------------------- - - IF(ictest >= 1) THEN - WRITE(*,*) ' ' - IF (ictest == 1) THEN - CALL mptest ! 'wire chamber' - ELSE - CALL mptst2(ictest-2) ! 'silicon tracker' - END IF - IF(filnam == ' ') filnam='mp2str.txt' - WRITE(*,*) ' ' - END IF - - ! check default steering file with file-name "steerfile" ----------- - - IF(filnam == ' ') THEN ! check default steering file - text='steerfile' - CALL rltext(text,ia,ib,nab) ! return indices for non-blank area - nu=nufile(text(ia:ib)) ! inquire on file existence and type - IF(nu > 0) THEN - filnam=text - ELSE - CALL peend(10,'Aborted, no steering file') - STOP 'in FILETC: no steering file. .' - END IF - END IF - - - ! open, read steering file: - ! end - ! fortranfiles - ! cfiles - - - CALL rltext(filnam,ia,ib,nfnam) ! return indices for non-blank area - WRITE(*,*) ' ' - WRITE(*,*) 'Listing of steering file: ',filnam(1:nfnam) - WRITE(*,*) '-------------------------' - OPEN(10,FILE=filnam(1:nfnam),IOSTAT=ios) - IF(ios /= 0) THEN - WRITE(*,*) 'Open error for steering file - stop' - CALL peend(11,'Aborted, open error for steering file') - STOP - END IF - ifile =0 - nfiles=0 - - lenfileInfo=2 - lenFileNames=0 - rows=6; cols=lenFileInfo - CALL mpalloc(vecfileInfo,rows,cols,'file info from steering') - nline=0 - DO - READ(10,102,IOSTAT=ierrf) text ! read steering file - IF (ierrf < 0) EXIT ! eof - CALL rltext(text,ia,ib,nab) ! return indices for non-blank area - nline=nline+1 - IF(nline <= 50) THEN ! print up to 50 lines - WRITE(*,101) nline,text(1:nab) - IF(nline == 50) WRITE(*,*) ' ...' - END IF - - CALL rltext(text,ia,ib,nab) ! test content 'end' - IF(ib == ia+2) THEN - mat=matint(text(ia:ib),'end',npat,ntext) - IF(mat == 3) THEN - text=' ' - CALL intext(text,nline) - WRITE(*,*) ' end-statement after',nline,' text lines' - EXIT - END IF - END IF - - keystx='fortranfiles' - mat=matint(text(ia:ib),keystx,npat,ntext) - IF(mat == ntext) THEN ! exact matching - nuf=3 - ! WRITE(*,*) 'Fortran files' - CYCLE - END IF - - keystx='Cfiles' - mat=matint(text(ia:ib),keystx,npat,ntext) - IF(mat == ntext) THEN ! exact matching - nuf=1 - ! WRITE(*,*) 'Cfiles' - CYCLE - END IF - - keystx='closeandreopen' ! don't keep binary files open - mat=matint(text(ia:ib),keystx,npat,ntext) - IF(mat == ntext) THEN ! exact matching - keepOpen=0 - CYCLE - END IF - - ! file names - ! check for file options (' -- ') - ie=ib - iopt=INDEX(text(ia:ib),' -- ') - IF (iopt > 0) ie=iopt-1 - - IF(nab == 0) CYCLE - nu=nufile(text(ia:ie)) ! inquire on file existence - IF(nu > 0) THEN ! existing file - IF (nfiles == lenFileInfo) THEN ! increase length - CALL mpalloc(tempArray,rows,cols,'temp file info from steering') - tempArray=vecfileInfo - CALL mpdealloc(vecfileInfo) - lenFileInfo=lenFileInfo*2 - newcols=lenFileInfo - CALL mpalloc(vecfileInfo,rows,newcols,'file info from steering') - vecfileInfo(:,1:cols)=tempArray(:,1:cols) - CALL mpdealloc(tempArray) - cols=newcols - ENDIF - nfiles=nfiles+1 ! count number of files - IF(nu == 1) nu=nuf ! - lenFileNames=lenFileNames+ie-ia+1 ! total length of file names - vecFileInfo(1,nfiles)=nline ! line number - vecFileInfo(2,nfiles)=nu ! cbinary =1, text =2, fbinary=3 - vecFileInfo(3,nfiles)=ia ! file name start - vecFileInfo(4,nfiles)=ie ! file name end - vecFileInfo(5,nfiles)=iopt ! option start - vecFileInfo(6,nfiles)=ib ! option end - ELSE - ! WRITE(*,*) 'Open error for file ',TEXT(IA:IB) - ! STOP - END IF - END DO - REWIND 10 - ! read again to fill dynamic arrays with file info - length=nfiles - CALL mpalloc(mfd,length,'file type') - CALL mpalloc(nfd,length,'file line (in steering)') - CALL mpalloc(lfd,length,'file name length') - CALL mpalloc(ofd,length,'file option') - length=lenFileNames - CALL mpalloc(tfd,length,'file name') - nline=0 - i=1 - ioff=0 - DO - READ(10,102,IOSTAT=ierrf) text ! read steering file - IF (ierrf < 0) EXIT ! eof - nline=nline+1 - IF (nline == vecFileInfo(1,i)) THEN - nfd(i)=vecFileInfo(1,i) - mfd(i)=vecFileInfo(2,i) - ia=vecFileInfo(3,i)-1 - lfd(i)=vecFileInfo(4,i)-ia ! length file name - FORALL (k=1:lfd(i)) tfd(ioff+k)=text(ia+k:ia+k) - ! tfd(i)=text(vecFileInfo(3,i):vecFileInfo(4,i)) ! file name - ioff=ioff+lfd(i) - ofd(i)=1.0 ! option for file - IF (vecFileInfo(5,i) > 0) THEN - CALL ratext(text(vecFileInfo(5,i)+4:vecFileInfo(6,i)),nums,dnum) ! translate text to DP numbers - IF (nums > 0) ofd(i)=REAL(dnum(1),mps) - END IF - i=i+1 - IF (i > nfiles) EXIT - ENDIF - ENDDO - CALL mpdealloc(vecfileInfo) - REWIND 10 - ! additional info for binary files - length=nfiles; rows=2 - CALL mpalloc(ifd,length,'integrated record numbers (=offset)') - CALL mpalloc(jfd,length,'number of accepted records') - CALL mpalloc(kfd,rows,length,'number of records in file, file order') - CALL mpalloc(dfd,length,'ndf sum') - CALL mpalloc(xfd,length,'max. record size') - CALL mpalloc(wfd,length,'file weight') - CALL mpalloc(cfd,length,'chi2 sum') - CALL mpalloc(sfd,rows,length,'start, end of file name in TFD') - CALL mpalloc(yfd,length,'modification date') - yfd=0 - ! - WRITE(*,*) '-------------------------' - WRITE(*,*) ' ' - - ! print table of files --------------------------------------------- - - IF (mprint > 1) THEN - WRITE(*,*) 'Table of files:' - WRITE(*,*) '---------------' - END IF - WRITE(8,*) ' ' - WRITE(8,*) 'Text and data files:' - ioff=0 - DO i=1,nfiles - FORALL (k=1:lfd(i)) fname(k:k)=tfd(ioff+k) - ! fname=tfd(i)(1:lfd(i)) - IF (mprint > 1) WRITE(*,103) i,bite(mfd(i)),fname(1:lfd(i)) - WRITE(8,103) i,bite(mfd(i)),fname(1:lfd(i)) - ioff=ioff+lfd(i) - END DO - IF (mprint > 1) THEN - WRITE(*,*) '---------------' - WRITE(*,*) ' ' - END IF - - ! open the binary Fortran (data) files on unit 11, 12, ... - - iosum=0 - nfilf=0 - nfilb=0 - nfilw=0 - ioff=0 - ifilb=0 - IF (keepOpen < 1) ifilb=1 - DO i=1,nfiles - IF(mfd(i) == 3) THEN - nfilf=nfilf+1 - nfilb=nfilb+1 - ! next file name - sfd(1,nfilb)=ioff - sfd(2,nfilb)=lfd(i) - CALL binopn(nfilb,ifilb,ios) - IF(ios == 0) THEN - wfd(nfilb)=ofd(i) - IF (keepOpen < 1) CALL bincls(nfilb,ifilb) - ELSE ! failure - iosum=iosum+1 - nfilf=nfilf-1 - nfilb=nfilb-1 - END IF - END IF - ioff=ioff+lfd(i) - END DO - - ! open the binary C files - - nfilc=-1 - ioff=0 - DO i=1,nfiles ! Cfiles - IF(mfd(i) == 1) THEN -#ifdef READ_C_FILES - IF(nfilc < 0) THEN ! initialize - CALL initc(max(nfiles,mthrdr)) ! uncommented by GF - nfilc=0 - END IF - nfilc=nfilc+1 - nfilb=nfilb+1 - ! next file name - sfd(1,nfilb)=ioff - sfd(2,nfilb)=lfd(i) - CALL binopn(nfilb,ifilb,ios) - IF(ios == 0) THEN - wfd(nfilb)=ofd(i) - IF (keepOpen < 1) CALL bincls(nfilb,ifilb) - ELSE ! failure - iosum=iosum+1 - nfilc=nfilc-1 - nfilb=nfilb-1 - END IF -#else - WRITE(*,*) 'Opening of C-files not supported.' - ! GF add - iosum=iosum+1 - ! GF add end -#endif - END IF - ioff=ioff+lfd(i) - END DO - - DO k=1,nfilb - kfd(1,k)=1 ! reset (negated) record counters - kfd(2,k)=k ! set file number - ifd(k)=0 ! reset integrated record numbers - xfd(k)=0 ! reset max record size - END DO - - IF(iosum /= 0) THEN - CALL peend(15,'Aborted, open error(s) for binary files') - STOP 'FILETC: open error ' - END IF - IF(nfilb == 0) THEN - CALL peend(14,'Aborted, no binary files') - STOP 'FILETC: no binary files ' - END IF - IF (keepOpen > 0) THEN - WRITE(*,*) nfilb,' binary files opened' ! corrected by GF - ELSE - WRITE(*,*) nfilb,' binary files opened and closed' ! corrected by GF - END IF -101 FORMAT(i3,2X,a) -102 FORMAT(a) -103 FORMAT(i3,2X,a14,3X,a) - ! CALL mend - RETURN -END SUBROUTINE filetc - -!> Interprete \ref ssec-textfiles "text files". -!! -!! Reset flags and read steering and all other text files. -!! Print some lines from each file. -!! -!! Store parameter values, constraints and measurements. -!! -!! Check flags METSOL (method of solution) and -!! MATSTO (matrix storage mode). -!! Set default values for flags, which are undefined. -!! -!! Parameter values, format: -!! -!! 1 label -!! 2 (initial) parameter value -!! 3 pre-sigma -!! 4 label -!! 5 (initial) parameter value -!! 6 pre-sigma -!! 7 label -!! ... ... -!! (number of words is multiple of 3) -!! -!! Constraint data, format: -!! -!! 1 0 ! constraint header of four words: -!! 2 right-hand-side ! 0 and -1 ... -!! 3 -1; -2 ! ... indicate (weighting) ... -!! 4 sigma ! ... header -!! 5 label -!! 6 factor -!! 7 label -!! 8 factor -!! 9 ... -!! ... ... -!! (number of words is multiple of 2, at least 6) -!! -!! Measured data, format: -!! -!! 1 0 ! constraint header of four words: -!! 2 right-hand-side ! 0 and -1 ... -!! 3 -1 ! ... indicate ... -!! 4 sigma ! ... header -!! 5 label -!! 6 factor -!! 7 label -!! 8 factor -!! 9 ... -!! ... ... -!! (number of words is multiple of 2, at least 6) - -SUBROUTINE filetx ! --------------------------------------------------- - USE mpmod - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ia - INTEGER(mpi) :: ib - INTEGER(mpi) :: ierrf - INTEGER(mpi) :: ioff - INTEGER(mpi) :: ios - INTEGER(mpi) :: iosum - INTEGER(mpi) :: k - INTEGER(mpi) :: mat - INTEGER(mpi) :: nab - INTEGER(mpi) :: nfiln - INTEGER(mpi) :: nline - INTEGER(mpi) :: nlinmx - INTEGER(mpi) :: npat - INTEGER(mpi) :: ntext - INTEGER(mpi) :: matint - - ! CALL MSTART('FILETX') - - CHARACTER (LEN=1024) :: text - CHARACTER (LEN=1024) :: fname - - WRITE(*,*) ' ' - WRITE(*,*) 'Processing text files ...' - WRITE(*,*) ' ' - - iosum=0 - ioff=0 - DO i=0,nfiles - IF(i == 0) THEN - WRITE(*,*) 'File ',filnam(1:nfnam) - nlinmx=100 - ELSE - nlinmx=10 - ia=ioff - ioff=ioff+lfd(i) - IF(mfd(i) /= 2) CYCLE ! exclude binary files - FORALL (k=1:lfd(i)) fname(k:k)=tfd(ia+k) - WRITE(*,*) 'File ',fname(1:lfd(i)) - IF (mprint > 1) WRITE(*,*) ' ' - OPEN(10,FILE=fname(1:lfd(i)),IOSTAT=ios,FORM='FORMATTED') - IF(ios /= 0) THEN - WRITE(*,*) 'Open error for file ',fname(1:lfd(i)) - iosum=iosum+1 - CYCLE - END IF - END IF - - nline=0 - nfiln=1 - ! read text file - DO - READ(10,102,IOSTAT=ierrf) text - IF (ierrf < 0) THEN - text=' ' - CALL intext(text,nline) - WRITE(*,*) ' end-of-file after',nline,' text lines' - EXIT ! eof - ENDIF - nline=nline+1 - IF(nline <= nlinmx.AND.mprint > 1) THEN ! print first 10 lines of every text fiLE - CALL rltext(text,ia,ib,nab) - nab=MAX(1,nab) - WRITE(*,101) nline,text(1:nab) - IF(nline == nlinmx) WRITE(*,*) ' ...' - END IF - - CALL rltext(text,ia,ib,nab) ! test content 'end' - IF(ib == ia+2) THEN - mat=matint(text(ia:ib),'end',npat,ntext) - IF(mat == 3) THEN - text=' ' - CALL intext(text,nline) - WRITE(*,*) ' end-statement after',nline,' text lines' - EXIT - END IF - END IF - - IF(i == 0) THEN ! first text file - exclude lines with file names - IF(nfiln <= nfiles.AND.nline == nfd(nfiln)) THEN - nfiln=nfiln+1 - text=' ' - ! WRITE(*,*) 'line is excluded ',TEXT(1:10) - END IF - END IF - ! WRITE(*,*) TEXT(1:40),' < interprete text' - CALL intext(text,nline) ! interprete text - END DO - WRITE(*,*) ' ' - REWIND 10 - CLOSE(UNIT=10) - END DO - - IF(iosum /= 0) THEN - CALL peend(16,'Aborted, open error(s) for text files') - STOP 'FILETX: open error(s) in text files ' - END IF - - WRITE(*,*) '... end of text file processing.' - WRITE(*,*) ' ' - - IF(lunkno /= 0) THEN - WRITE(*,*) ' ' - WRITE(*,*) lunkno,' unknown keywords in steering files, ', & - 'or file non-existing,' - WRITE(*,*) ' see above!' - WRITE(*,*) '------------> stop' - WRITE(*,*) ' ' - CALL peend(13,'Aborted, unknown keywords in steering file') - STOP - END IF - - ! check methods - - IF(metsol == 0) THEN ! if undefined - IF(matsto == 0) THEN ! if undefined - ! METSOL=1 ! default is matrix inversion - ! MATSTO=1 ! default is symmetric matrix - ELSE IF(matsto == 1) THEN ! if symmetric - metsol=3 ! MINRES - ELSE IF(matsto == 2) THEN ! if sparse - metsol=3 ! MINRES - END IF - ELSE IF(metsol == 1) THEN ! if inversion - matsto=1 ! - ELSE IF(metsol == 2) THEN ! if diagonalization - matsto=1 - ELSE IF(metsol == 3) THEN ! if MINRES - ! MATSTO=2 or 1 - ELSE IF(metsol == 4) THEN ! if MINRES-QLP - ! MATSTO=2 or 1 - ELSE IF(metsol == 5) THEN ! if GMRES - ! MATSTO=2 or 1 - ELSE - WRITE(*,*) 'MINRES forced with sparse matrix!' - WRITE(*,*) ' ' - WRITE(*,*) 'MINRES forced with sparse matrix!' - WRITE(*,*) ' ' - WRITE(*,*) 'MINRES forced with sparse matrix!' - metsol=3 ! forced - matsto=2 ! forced - END IF - IF(matsto > 2) THEN - WRITE(*,*) 'MINRES forced with sparse matrix!' - WRITE(*,*) ' ' - WRITE(*,*) 'MINRES forced with sparse matrix!' - WRITE(*,*) ' ' - WRITE(*,*) 'MINRES forced with sparse matrix!' - metsol=3 ! forced - matsto=2 ! forced - END IF - - ! print information about methods and matrix storage modes - - WRITE(*,*) ' ' - WRITE(*,*) 'Solution method and matrix-storage mode:' - IF(metsol == 1) THEN - WRITE(*,*) ' METSOL = 1: matrix inversion' - ELSE IF(metsol == 2) THEN - WRITE(*,*) ' METSOL = 2: diagonalization' - ELSE IF(metsol == 3) THEN - WRITE(*,*) ' METSOL = 3: MINRES' - ELSE IF(metsol == 4) THEN - WRITE(*,*) ' METSOL = 4: MINRES-QLP' - ELSE IF(metsol == 5) THEN - WRITE(*,*) ' METSOL = 5: GMRES (-> MINRES)' - - END IF - - WRITE(*,*) ' with',mitera,' iterations' - - IF(matsto == 1) THEN - WRITE(*,*) ' MATSTO = 1: symmetric matrix, ', '(n*n+n)/2 elements' - ELSE IF(matsto == 2) THEN - WRITE(*,*) ' MATSTO = 2: sparse matrix' - END IF - IF(mbandw /= 0) THEN - WRITE(*,*) ' and band matrix, width',mbandw - END IF - - IF(chicut /= 0.0) THEN - WRITE(*,*) 'Chi square cut equiv 3 st.dev applied ...' - WRITE(*,*) ' in first iteration with factor',chicut - WRITE(*,*) ' in second iteration with factor',chirem - WRITE(*,*) ' (reduced by sqrt in next iterations)' - END IF - - IF(lhuber /= 0) THEN - WRITE(*,*) ' Down-weighting of outliers in', lhuber,' iterations' - WRITE(*,*) ' Cut on downweight fraction',dwcut - END IF - - WRITE(*,*) 'Iterations (solutions) with line search:' - IF(lsearch > 2) THEN - WRITE(*,*) ' All' - ELSEIF (lsearch == 1) THEN - WRITE(*,*) ' Last' - ELSEIF (lsearch < 1) THEN - WRITE(*,*) ' None' - ELSE - IF (chicut /= 0.0) THEN - WRITE(*,*) ' All with Chi square cut scaling factor <= 1.' - ELSE - WRITE(*,*) ' All' - ENDIF - ENDIF - - IF(numMeasurements>0) THEN - WRITE(*,*) - WRITE(*,*) ' Number of external measurements ', numMeasurements - ENDIF - - CALL mend - -101 FORMAT(i3,2X,a) -102 FORMAT(a) -END SUBROUTINE filetx - -!> Inquire on file. -!! -!! Result = 1 for existing binary file, =2 for existing text file, else =0, -!! < 0 open error. -!! -!! Text file names are recognized by the filename extension, which -!! should contain 'xt' or 'tx'. -!! -!! \param [in,out] fname file name, optionaly strip prefix. - -INTEGER(mpi) FUNCTION nufile(fname) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: ios - INTEGER(mpi) :: l1 - INTEGER(mpi) :: ll - INTEGER(mpi) :: nm - INTEGER(mpi) :: npat - INTEGER(mpi) :: ntext - INTEGER(mpi) :: nuprae - INTEGER(mpi) :: matint - - CHARACTER (LEN=*), INTENT(INOUT) :: fname - LOGICAL :: ex - SAVE - ! ... - nufile=0 - IF(fname(1:5) == 'rfio:') nuprae=1 - IF(fname(1:5) == 'dcap:') nuprae=2 - IF(fname(1:5) == 'root:') nuprae=3 - IF(nuprae == 0) THEN - INQUIRE(FILE=fname,IOSTAT=ios,EXIST=ex) - IF(ios /= 0) nufile=-ABS(ios) - IF(ios /= 0) RETURN - ELSE IF(nuprae == 1) THEN ! rfio: - ll=LEN(fname) - fname=fname(6:ll) - ex=.TRUE. - nufile=1 - RETURN - ELSE - ex=.TRUE. ! assume file existence - END IF - IF(ex) THEN - nufile=1 ! binary - ll=LEN(fname) - l1=MAX(1,ll-3) - nm=matint('xt',fname(l1:ll),npat,ntext) - IF(nm == 2) nufile=2 ! text - IF(nm < 2) THEN - nm=matint('tx',fname(l1:ll),npat,ntext) - IF(nm == 2) nufile=2 ! text - END IF - END IF -END FUNCTION nufile - -!> Interprete text. -!! -!! Look for keywords and argument in text line. -!! -!! \param[in] text text -!! \param[in] nline line number -!! -SUBROUTINE intext(text,nline) - USE mpmod - USE mptext - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ia - INTEGER(mpi) :: ib - INTEGER(mpi) :: ier - INTEGER(mpi) :: iomp - INTEGER(mpi) :: k - INTEGER(mpi) :: kkey - INTEGER(mpi) :: label - INTEGER(mpi) :: lkey - INTEGER(mpi) :: mat - INTEGER(mpi) :: miter - INTEGER(mpi) :: nab - INTEGER(mpi) :: nkey - INTEGER(mpi) :: nkeys - INTEGER(mpi) :: nl - INTEGER(mpi) :: nmeth - INTEGER(mpi) :: npat - INTEGER(mpi) :: ntext - INTEGER(mpi) :: nums - INTEGER(mpi) :: matint - - CHARACTER (LEN=*), INTENT(IN) :: text - INTEGER(mpi), INTENT(IN) :: nline - - PARAMETER (nkeys=5,nmeth=6) - CHARACTER (LEN=16) :: methxt(nmeth) - CHARACTER (LEN=16) :: keylst(nkeys) - CHARACTER (LEN=32) :: keywrd - CHARACTER (LEN=32) :: keystx - REAL(mpd) :: dnum(100) - INTEGER(mpi) :: lpvs ! ... integer - REAL(mpd) :: plvs ! ... float - - INTERFACE - SUBROUTINE addItem(length,list,label,value) - USE mpmod - INTEGER(mpi), INTENT(IN OUT) :: length - TYPE(listItem), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list - INTEGER(mpi), INTENT(IN) :: label - REAL(mpd), INTENT(IN) :: value - END SUBROUTINE addItem - END INTERFACE - - DATA keylst/'unknown','parameter','constraint','measurement','method'/ - - SAVE - DATA methxt/'diagonalization','inversion','fullMINRES', 'sparseMINRES', & - 'fullMINRES-QLP', 'sparseMINRES-QLP'/ - DATA lkey/-1/ ! last keyword - - ! ... - nkey=-1 ! new keyword - CALL rltext(text,ia,ib,nab) ! return indices for non-blank area - IF(nab == 0) GOTO 10 - CALL ratext(text(1:nab),nums,dnum) ! translate text to DP numbers - - IF(nums /= 0) nkey=0 - IF(keyb /= 0) THEN - keywrd=text(keya:keyb) ! text is TEXT(KEYA)...TEXT(KEYB) - ! WRITE(*,*) 'Keyword is ',KEYWRD - - ! compare keywords - - DO nkey=2,nkeys ! loop over all pede keywords - keystx=keylst(nkey) ! copy NKEY.th pede keyword - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= ntext-ntext/5) GO TO 10 - END DO - - ! more comparisons - - keystx='print' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - ! WRITE(*,*) KEYSTX,MAT,NTEXT - ! IF(MAT.GE.NTEXT) THEN - IF(mat >= (npat-npat/5)) THEN - ! IF(MAT.GE.(NTEXT+NTEXT+3)/3) THEN - mprint=1 - IF(nums > 0) mprint=NINT(dnum(1),mpi) - RETURN - END IF - - keystx='debug' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - ! IF(MAT.GE.(NTEXT+NTEXT+3)/3) THEN - mdebug=3 - ! GF IF(NUMS.GT.0) MPRINT=DNUM(1) - IF(nums > 0) mdebug=NINT(dnum(1),mpi) - IF(nums > 1) mdebg2=NINT(dnum(2),mpi) - RETURN - END IF - - keystx='entries' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - ! IF(MAT.GE.(NTEXT+NTEXT+3)/3) THEN - IF(nums > 0 .AND. dnum(1) > 0.5) mreqenf=NINT(dnum(1),mpi) - IF(nums > 1 .AND. dnum(2) > 0.5) mreqena=NINT(dnum(2),mpi) - IF(nums > 2 .AND. dnum(3) > 0.5) iteren=NINT(dnum(1)*dnum(3),mpi) - RETURN - END IF - - keystx='printrecord' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - IF(nums > 0) nrecpr=NINT(dnum(1),mpi) - IF(nums > 1) nrecp2=NINT(dnum(2),mpi) - RETURN - END IF - - keystx='maxrecord' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - IF (nums > 0.AND.dnum(1) > 0.) mxrec=NINT(dnum(1),mpi) - RETURN - END IF - - keystx='cache' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - IF (nums > 0.AND.dnum(1) >= 0.) ncache=NINT(dnum(1),mpi) ! cache size, <0 keeps default - IF (nums == 2.AND.dnum(2) > 0..AND.dnum(2) <= 1.0) & ! read cache fill level - fcache(1)=REAL(dnum(2),mps) - IF (nums >= 4) THEN ! explicit cache splitting - DO k=1,3 - fcache(k)=REAL(dnum(k+1),mps) - END DO - END IF - RETURN - END IF - - keystx='chisqcut' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - IF(nums == 0) THEN ! always 3-sigma cut - chicut=1.0 - chirem=1.0 - ELSE - chicut=REAL(dnum(1),mps) - IF(chicut < 1.0) chicut=-1.0 - IF(nums == 1) THEN - chirem=1.0 ! 3-sigma cut, if not specified - ELSE - chirem=REAL(dnum(2),mps) - IF(chirem < 1.0) chirem=1.0 - IF(chicut >= 1.0) chirem=MIN(chirem,chicut) - END IF - END IF - RETURN - END IF - - ! GF added: - keystx='hugecut' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - IF(nums > 0) chhuge=REAL(dnum(1),mps) - IF(chhuge < 1.0) chhuge=1.0 ! at least (!!) 3-sigma - RETURN - END IF - ! GF added end - - keystx='linesearch' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - IF(nums > 0) lsearch=NINT(dnum(1),mpi) - RETURN - END IF - - keystx='localfit' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - IF(nums > 0) lfitnp=NINT(dnum(1),mpi) - IF(nums > 1) lfitbb=NINT(dnum(2),mpi) - RETURN - END IF - - keystx='regularization' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - nregul=1 - regula=REAL(dnum(1),mps) - IF(nums >= 2) regpre=REAL(dnum(2),mps) - RETURN - END IF - - keystx='regularisation' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - nregul=1 - regula=REAL(dnum(1),mps) - IF(nums >= 2) regpre=REAL(dnum(2),mps) - RETURN - END IF - - keystx='presigma' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - regpre=REAL(dnum(1),mps) - RETURN - END IF - - keystx='matiter' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - matrit=NINT(dnum(1),mpi) - RETURN - END IF - - keystx='matmoni' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - matmon=-1 - IF (nums > 0.AND.dnum(1) > 0.) matmon=NINT(dnum(1),mpi) - RETURN - END IF - - keystx='bandwidth' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - ! IF(MAT.GE.(NTEXT+NTEXT+3)/3) THEN - IF(mat >= (npat-npat/5)) THEN - IF(nums > 0) mbandw=NINT(dnum(1),mpi) - IF(mbandw < 0) mbandw=-1 - IF(nums > 1) lprecm=NINT(dnum(2),mpi) - RETURN - END IF - - ! KEYSTX='outlierrejection' - ! MAT=MATINT(TEXT(KEYA:KEYB),KEYSTX,NPAT,NTEXT) ! comparison - ! WRITE(*,*) KEYSTX,MAT,(NTEXT+NTEXT)/3 - ! IF(MAT.GE.(NTEXT+NTEXT+NTEXT-2)/3) THEN - ! IF(MAT.GE.(NPAT-NPAT/5)) THEN - ! CHDFRJ=DNUM(1) - ! IF(CHDFRJ.LT.3.0) CHDFRJ=100.0 - ! RETURN - ! END IF - - ! KEYSTX='outliersuppression' - ! MAT=MATINT(TEXT(KEYA:KEYB),KEYSTX,NPAT,NTEXT) ! comparison - ! WRITE(*,*) KEYSTX,MAT,(NTEXT+NTEXT)/3 - ! IF(MAT.GE.(NTEXT+NTEXT+NTEXT-2)/3) THEN - ! IF(MAT.GE.(NPAT-NPAT/5)) THEN - ! LHUBER=DNUM(1) - ! IF(LHUBER.LE.2) LHUBER=2 ! at least 2 Huber iterations - ! RETURN - ! END IF - - keystx='outlierdownweighting' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - ! WRITE(*,*) KEYSTX,MAT,(NTEXT+NTEXT)/3 - ! IF(MAT.GE.(NTEXT+NTEXT+NTEXT-2)/3) THEN - IF(mat >= (npat-npat/5)) THEN - lhuber=NINT(dnum(1),mpi) - IF(lhuber > 0.AND.lhuber <= 2) lhuber=2 ! at least 2 Huber iterations (if any) - RETURN - END IF - - keystx='dwfractioncut' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - dwcut=REAL(dnum(1),mps) - IF(dwcut > 0.5) dwcut=0.5 - RETURN - END IF - - keystx='pullrange' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - prange=ABS(REAL(dnum(1),mps)) - RETURN - END IF - - keystx='subito' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - isubit=1 - RETURN - END IF - - keystx='force' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - iforce=1 - RETURN - END IF - - keystx='memorydebug' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - memdbg=1 - IF (nums > 0.AND.dnum(1) > 0.0) memdbg=NINT(dnum(1),mpi) - RETURN - END IF - - keystx='globalcorr' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - igcorr=1 - RETURN - END IF - - keystx='printcounts' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - ipcntr=1 - IF (nums > 0.AND.dnum(1) > 0.0) ipcntr=NINT(dnum(1),mpi) - RETURN - END IF - - keystx='weightedcons' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - iwcons=1 - IF (nums > 0) iwcons=NINT(dnum(1),mpi) - RETURN - END IF - - keystx='skipemptycons' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - iskpec=1 - RETURN - END IF - - keystx='withelimination' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - icelim=1 - RETURN - END IF - - keystx='withmultipliers' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - icelim=0 - RETURN - END IF - - keystx='checkinput' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - icheck=1 - IF (nums > 0) icheck=NINT(dnum(1),mpi) - RETURN - END IF - - keystx='monitorresiduals' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - imonit=3 - IF (nums > 0) imonit=NINT(dnum(1),mpi) - IF (nums > 1) measBins=max(measBins,NINT(dnum(2),mpi)) - RETURN - END IF - - keystx='monitorpulls' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - imonit=3 - imonmd=1 - IF (nums > 0) imonit=NINT(dnum(1),mpi) - IF (nums > 1) measBins=max(measBins,NINT(dnum(2),mpi)) - RETURN - END IF - - keystx='scaleerrors' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - iscerr=1 - IF (nums > 0) dscerr(1:2)=dnum(1) - IF (nums > 1) dscerr(2)=dnum(2) - RETURN - END IF - - keystx='iterateentries' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - iteren=huge(iteren) - IF (nums > 0) iteren=NINT(dnum(1),mpi) - RETURN - END IF - - keystx='threads' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - iomp=0 - !$ IOMP=1 - !$ IF (IOMP.GT.0) THEN - !$ IF (NUMS.GE.1.AND.DNUM(1).GT.0.) MTHRD =NINT(dnum(1),mpi) - !$ IF (NUMS.GE.2) THEN - !$ MTHRDR=MTHRD - !$ IF (DNUM(2).GT.0.) MTHRDR=NINT(dnum(2),mpi) - !$ ENDIF - !$ ELSE - WRITE(*,*) 'WARNING: multithreading not available' - !$ ENDIF - RETURN - END IF - - keystx='compress' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - mcmprs=1 - RETURN - END IF - - ! still experimental - !keystx='extendedStorage' - !mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - !IF(mat >= (npat-npat/5)) THEN - ! mextnd=1 - ! ! compression enforced for extended storage (in mpbits) - ! RETURN - !END IF - - keystx='errlabels' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5).AND.mnrsel < 100) THEN - nl=MIN(nums,100-mnrsel) - DO k=1,nl - lbmnrs(mnrsel+k)=NINT(dnum(k),mpi) - END DO - mnrsel=mnrsel+nl - RETURN - END IF - - keystx='pairentries' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - ! This option could be implemented to get rid of parameter pairs - ! that have very few entries - to save matrix memory size. - IF (nums > 0.AND.dnum(1) > 0.0) THEN - mreqpe=NINT(dnum(1),mpi) - IF (nums >= 2.AND.dnum(2) >= dnum(1)) mhispe=NINT(dnum(2),mpi) - IF (nums >= 3.AND.dnum(3) >= dnum(1)) msngpe=NINT(dnum(3),mpi) - END IF - RETURN - END IF - - keystx='wolfe' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - wolfc1=REAL(dnum(1),mps) - wolfc2=REAL(dnum(2),mps) - RETURN - END IF - - ! GF added: - ! convergence tolerance for minres: - keystx='mrestol' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - IF(nums > 0) THEN - IF (dnum(1) < 1.0E-10_mpd.OR.dnum(1) > 1.0E-04_mpd) THEN - WRITE(*,*) 'ERROR: need 1.0D-10 <= MRESTL ', & - '<= 1.0D-04, but get ', dnum(1) - ELSE - mrestl=dnum(1) - END IF - END IF - RETURN - END IF - ! GF added end - - keystx='mrestranscond' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - IF(nums > 0) THEN - mrtcnd = dnum(1) - END IF - RETURN - END IF - - keystx='mresmode' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - IF(nums > 0) THEN - mrmode = INT(dnum(1),mpi) - END IF - RETURN - END IF - - keystx='nofeasiblestart' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= (npat-npat/5)) THEN - nofeas=1 ! do not make parameters feasible at start - RETURN - END IF - - keystx='histprint' - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= ntext-ntext/10) THEN - ! IF(MAT.GE.(NPAT-NPAT/5)) THEN - nhistp=1 ! print histograms - RETURN - END IF - - keystx='fortranfiles' - mat=matint(text(ia:ib),keystx,npat,ntext) ! comparison - IF(mat >= ntext-ntext/10) RETURN - - keystx='Cfiles' - mat=matint(text(ia:ib),keystx,npat,ntext) ! comparison - IF(mat >= ntext-ntext/10) RETURN - - keystx='closeandreopen' - mat=matint(text(ia:ib),keystx,npat,ntext) ! comparison - IF(mat >= ntext-ntext/10) RETURN - - keystx=keylst(1) - nkey=1 ! unknown keyword - IF(nums /= 0) nkey=0 - - WRITE(*,*) ' ' - WRITE(*,*) '**************************************************' - WRITE(*,*) ' ' - WRITE(*,*) 'Unknown keyword(s): ',text(1:MIN(nab,50)) - WRITE(*,*) ' ' - WRITE(*,*) '**************************************************' - WRITE(*,*) ' ' - lunkno=lunkno+1 - - END IF - ! result: NKEY = -1 blank - ! NKEY = 0 numerical data, no text keyword or unknown - ! NKEY > 0 keyword NKEY from list, keyword = KEYSTX - - - ! content/lastcontent - ! ------------------- - ! blank -1 - ! data 0 - ! keyword - ! unknown 1 - ! parameter 2 - ! constraint 3 - ! measurement 4 - ! method 5 - - -10 IF(nkey > 0) THEN ! new keyword - lkey=nkey - IF(lkey == 2) THEN ! parameter - IF(nums == 3) THEN - lpvs=NINT(dnum(1),mpi) ! label - IF(lpvs /= 0) THEN - CALL addItem(lenParameters,listParameters,lpvs,dnum(2)) ! start value - CALL addItem(lenPreSigmas,listPresigmas,lpvs,dnum(3)) ! pre-sigma - ELSE - WRITE(*,*) 'Line',nline,' error, label=',lpvs - END IF - ELSE IF(nums /= 0) THEN - kkey=1 ! switch to "unknown" ? - WRITE(*,*) 'Wrong text in line',nline - WRITE(*,*) 'Status: new parameter' - WRITE(*,*) '> ',text(1:nab) - END IF - ELSE IF(lkey == 3) THEN ! constraint - ! WRITE(*,*) 'Keyword is constraint!',NUMS,' numerical data' - IF(nums >= 1.AND.nums <= 2) THEN ! start constraint - lpvs=0 ! r = r.h.s. value - CALL addItem(lenConstraints,listConstraints,lpvs,dnum(1)) - lpvs=-1 ! constraint - IF(iwcons > 0) lpvs=-2 ! weighted constraint - plvs=0.0 - IF(nums == 2) plvs=dnum(2) ! sigma - CALL addItem(lenConstraints,listConstraints,lpvs,plvs) - ELSE - kkey=1 ! switch to "unknown" - WRITE(*,*) 'Wrong text in line',nline - WRITE(*,*) 'Status: new keyword constraint' - WRITE(*,*) '> ',text(1:nab) - END IF - ELSE IF(lkey == 4) THEN ! measurement - IF(nums == 2) THEN ! start measurement - numMeasurements=numMeasurements+1 - lpvs=0 ! r = r.h.s. value - CALL addItem(lenMeasurements,listMeasurements,lpvs,dnum(1)) - lpvs=-1 ! sigma - CALL addItem(lenMeasurements,listMeasurements,lpvs,dnum(2)) - ELSE - kkey=1 ! switch to "unknown" - WRITE(*,*) 'Wrong text in line',nline - WRITE(*,*) 'Status: new keyword measurement' - WRITE(*,*) '> ',text(1:nab) - END IF - - ELSE IF(lkey == 5) THEN ! method - miter=mitera - IF(nums >= 1) miter=NINT(dnum(1),mpi) - IF(miter >= 1) mitera=miter - dflim=REAL(dnum(2),mps) - lkey=0 - DO i=1,nmeth - keystx=methxt(i) - mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison - IF(mat >= ntext-ntext/5) THEN - IF(i == 1) THEN ! diagonalization - metsol=2 - matsto=1 - ELSE IF(i == 2) THEN ! inversion - metsol=1 - matsto=1 - ELSE IF(i == 3) THEN ! fullMINRES - metsol=3 - matsto=1 - ELSE IF(i == 4) THEN ! sparseMINRES - metsol=3 - matsto=2 - ELSE IF(i == 5) THEN ! fullMINRES-QLP - metsol=4 - matsto=1 - ELSE IF(i == 6) THEN ! sparseMINRES-QLP - metsol=4 - matsto=2 - END IF - END IF - END DO - END IF - ELSE IF(nkey == 0) THEN ! data for continuation - IF(lkey == 2) THEN ! parameter - IF(nums >= 3) THEN ! store data from this line - lpvs=NINT(dnum(1),mpi) ! label - IF(lpvs /= 0) THEN - CALL addItem(lenParameters,listParameters,lpvs,dnum(2)) ! start value - CALL addItem(lenPreSigmas,listPresigmas,lpvs,dnum(3)) ! pre-sigma - ELSE - WRITE(*,*) 'Line',nline,' error, label=',lpvs - END IF - ELSE IF(nums > 1.AND.nums < 3) THEN - kkey=1 ! switch to "unknown" ? - WRITE(*,*) 'Wrong text in line',nline - WRITE(*,*) 'Status continuation parameter' - WRITE(*,*) '> ',text(1:nab) - END IF - - ELSE IF(lkey == 3) THEN ! constraint - ier=0 - DO i=1,nums,2 - label=NINT(dnum(i),mpi) - IF(label <= 0) ier=1 - END DO - IF(MOD(nums,2) /= 0) ier=1 ! reject odd number - IF(ier == 0) THEN - DO i=1,nums,2 - lpvs=NINT(dnum(i),mpi) ! label - plvs=dnum(i+1) ! factor - CALL addItem(lenConstraints,listConstraints,lpvs,plvs) - END DO - ELSE - kkey=0 - WRITE(*,*) 'Wrong text in line',nline - WRITE(*,*) 'Status continuation constraint' - WRITE(*,*) '> ',text(1:nab) - END IF - - ELSE IF(lkey == 4) THEN ! measurement - ! WRITE(*,*) 'continuation < ',NUMS - ier=0 - DO i=1,nums,2 - label=NINT(dnum(i),mpi) - IF(label <= 0) ier=1 - END DO - IF(MOD(nums,2) /= 0) ier=1 ! reject odd number - ! WRITE(*,*) 'IER NUMS ',IER,NUMS - IF(ier == 0) THEN - DO i=1,nums,2 - lpvs=NINT(dnum(i),mpi) ! label - plvs=dnum(i+1) ! factor - CALL addItem(lenMeasurements,listMeasurements,lpvs,plvs) - END DO - ELSE - kkey=0 - WRITE(*,*) 'Wrong text in line',nline - WRITE(*,*) 'Status continuation measurement' - WRITE(*,*) '> ',text(1:nab) - END IF - - END IF - END IF -END SUBROUTINE intext - -!> add item to list -!! -!! \param [in,out] length length of list -!! \param [in,out] list list of items -!! \param [in] label item label -!! \param [in] value item value -!! -SUBROUTINE addItem(length,list,label,value) - USE mpdef - USE mpdalc - - INTEGER(mpi), INTENT(IN OUT) :: length - TYPE(listItem), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list - INTEGER(mpi), INTENT(IN) :: label - REAL(mpd), INTENT(IN) :: value - - INTEGER(mpl) :: newSize - INTEGER(mpl) :: oldSize - TYPE(listItem), DIMENSION(:), ALLOCATABLE :: tempList - - IF (label > 0.AND.value == 0.) RETURN ! skip zero for valid labels - IF (length == 0 ) THEN ! initial list with size = 100 - newSize = 100 - CALL mpalloc(list,newSize,' list ') - ENDIF - oldSize=size(list,kind=mpl) - IF (length >= oldSize) THEN ! increase sizeby 20% + 100 - newSize = oldSize + oldSize/5 + 100 - CALL mpalloc(tempList,oldSize,' temp. list ') - tempList=list - CALL mpdealloc(list) - CALL mpalloc(list,newSize,' list ') - list(1:oldSize)=tempList(1:oldSize) - CALL mpdealloc(tempList) - ENDIF - ! add to end of list - length=length+1 - list(length)%label=label - list(length)%value=value - -END SUBROUTINE addItem - -!> Start of 'module' printout. -SUBROUTINE mstart(text) - USE mpdef - USE mpmod, ONLY: textl - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ka - INTEGER(mpi) :: kb - INTEGER(mpi) :: l - CHARACTER (LEN=*), INTENT(IN) :: text - CHARACTER (LEN=16) :: textc - SAVE - ! ... - DO i=1,74 - textl(i:i)='_' - END DO - l=LEN(text) - ka=(74-l)/2 - kb=ka+l-1 - textl(ka:kb)=text(1:l) - WRITE(*,*) ' ' - WRITE(*,*) textl - WRITE(*,*) ' ' - textc=text(1:l)//'-end' - - DO i=1,74 - textl(i:i)='_' - END DO - l=l+4 - ka=(74-l)/2 - kb=ka+l-1 - textl(ka:kb)=textc(1:l) - RETURN -END SUBROUTINE mstart - -!> End of 'module' printout. -SUBROUTINE mend - USE mpmod, ONLY: textl - - IMPLICIT NONE - WRITE(*,*) ' ' - WRITE(*,*) textl - CALL petime - WRITE(*,*) ' ' -END SUBROUTINE mend - -!> Open file. -!! -!! Evtl. move existing file to ~ version. -!! -!! \param[in] lun unit number -!! \param[in] fname file name - -SUBROUTINE mvopen(lun,fname) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: l - INTEGER(mpi), INTENT(IN) :: lun - CHARACTER (LEN=*), INTENT(IN) :: fname - CHARACTER (LEN=33) :: nafile - CHARACTER (LEN=33) :: nbfile - LOGICAL :: ex - SAVE - ! ... - l=LEN(fname) - IF(l > 32) THEN - CALL peend(17,'Aborted, file name too long') - STOP 'File name too long ' - END IF - nafile=fname - nafile(l+1:l+1)='~' - - INQUIRE(FILE=nafile(1:l),EXIST=ex) - IF(ex) THEN - INQUIRE(FILE=nafile(1:l+1),EXIST=ex) - IF(ex) THEN - CALL system('rm '//nafile) - END IF - nbfile=nafile - nafile(l+1:l+1)=' ' - CALL system('mv '//nafile//nbfile) - END IF - OPEN(UNIT=lun,FILE=fname) -END SUBROUTINE mvopen - -!> Print times. -!! -!! Print the elapsed and total time. - -SUBROUTINE petime - USE mpdef - - IMPLICIT NONE - REAL, DIMENSION(2) :: ta - REAL :: rst - REAL :: delta - REAL :: rstp - REAL :: secnd1 - REAL :: secnd2 - INTEGER :: ncount - INTEGER :: nhour1 - INTEGER :: minut1 - INTEGER :: nsecd1 - INTEGER :: nhour2 - INTEGER :: minut2 - INTEGER :: nsecd2 - - SAVE - DATA ncount/0/ - ! ... - ncount=ncount+1 - CALL etime(ta,rst) - IF(ncount > 1) THEN - delta=rst - nsecd1=INT(delta,mpi) ! -> integer - nhour1=nsecd1/3600 - minut1=nsecd1/60-60*nhour1 - secnd1=delta-60*(minut1+60*nhour1) - delta=rst-rstp - nsecd2=INT(delta,mpi) ! -> integer - nhour2=nsecd2/3600 - minut2=nsecd2/60-60*nhour2 - secnd2=delta-60*(minut2+60*nhour2) - WRITE(*,101) nhour1,minut1,secnd1, nhour2,minut2,secnd2 - END IF - - rstp=rst - RETURN -101 FORMAT(i4,' h',i3,' min',f5.1,' sec total',18X,'elapsed', & - i4,' h',i3,' min',f5.1,' sec') -END SUBROUTINE petime ! print - -!> Print exit code. -!! -!! Print exit code and message. -!! -!! \param[in] icode exit code -!! \param[in] cmessage exit massage - -SUBROUTINE peend(icode, cmessage) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi), INTENT(IN) :: icode - CHARACTER (LEN=*), INTENT(IN) :: cmessage - - CALL mvopen(9,'millepede.end') - WRITE(9,101) icode, cmessage -101 FORMAT(1X,I4,3X,A) - RETURN - -END SUBROUTINE peend - -!> Open binary file. -!! -!! \param[in] kfile file number -!! \param[in] ithr thread number ([1..nthrd] - close and reopen) or 0 (next file - keep open) for C files -!! \param[out] ierr error flag -!! -SUBROUTINE binopn(kfile, ithr, ierr) - USE mpmod - - IMPLICIT NONE - INTEGER(mpi), INTENT(IN) :: kfile - INTEGER(mpi), INTENT(IN) :: ithr - INTEGER(mpi), INTENT(OUT) :: ierr - - INTEGER(mpi), DIMENSION(13) :: ibuff - INTEGER(mpi) :: ioff - INTEGER(mpi) :: ios - INTEGER(mpi) :: k - INTEGER(mpi) :: lfn - INTEGER(mpi) :: lun - INTEGER(mpi) :: moddate - CHARACTER (LEN=1024) :: fname - - ierr=0 - lun=ithr - ! modification date (=0: open for first time, >0: reopen, <0: unknown ) - moddate=yfd(kfile) - ! file name - ioff=sfd(1,kfile) - lfn=sfd(2,kfile) - FORALL (k=1:lfn) fname(k:k)=tfd(ioff+k) - !print *, " opening binary ", kfile, ithr, moddate, " : ", fname(1:lfn) - ! open - ios=0 - IF(kfile <= nfilf) THEN - ! Fortran file - lun=kfile+10 - OPEN(lun,FILE=fname(1:lfn),IOSTAT=ios, FORM='UNFORMATTED') - print *, ' lun ', lun, ios -#ifdef READ_C_FILES - ELSE - ! C file - CALL openc(fname(1:lfn),lun,ios) -#else - WRITE(*,*) 'Opening of C-files not supported.' - ierr=1 - RETURN -#endif - END IF - IF(ios /= 0) THEN - ierr=1 - WRITE(*,*) 'Open error for file ',fname(1:lfn), ios - IF (moddate /= 0) THEN - CALL peend(15,'Aborted, open error(s) for binary files') - STOP 'PEREAD: open error ' - ENDIF - RETURN - END IF - ! get status - CALL stat(fname(1:lfn),ibuff,ios) - !print *, ' STAT ', ios, ibuff(10), moddate - IF(ios /= 0) THEN - ierr=1 - WRITE(*,*) 'STAT error for file ',fname(1:lfn), ios - ibuff(10)=-1 - END IF - ! check/store modification date - IF (moddate /= 0) THEN - IF (ibuff(10) /= moddate) THEN - CALL peend(19,'Aborted, binary file(s) modified') - STOP 'PEREAD: file modified ' - END IF - ELSE - yfd(kfile)=ibuff(10) - END IF - RETURN - -END SUBROUTINE binopn - -!> Close binary file. -!! -!! \param[in] kfile file number -!! \param[in] ithr thread number ([1..nthrd] - close and reopen) for C files -!! -SUBROUTINE bincls(kfile, ithr) - USE mpmod - - IMPLICIT NONE - INTEGER(mpi), INTENT(IN) :: kfile - INTEGER(mpi), INTENT(IN) :: ithr - - INTEGER(mpi) :: lun - - lun=ithr - !print *, " closing binary ", kfile, ithr - IF(kfile <= nfilf) THEN ! Fortran file - lun=kfile+10 - CLOSE(lun) -#ifdef READ_C_FILES - ELSE ! C file - CALL closec(lun) -#endif - END IF - -END SUBROUTINE bincls - -!> Rewind binary file. -!! -!! \param[in] kfile file number -!! -SUBROUTINE binrwd(kfile) - USE mpmod - - IMPLICIT NONE - INTEGER(mpi), INTENT(IN) :: kfile - - INTEGER(mpi) :: lun - - !print *, " rewinding binary ", kfile - IF (kfile <= nfilf) THEN - lun=kfile+10 - REWIND lun -#ifdef READ_C_FILES - ELSE - lun=kfile-nfilf - CALL resetc(lun) -#endif - END IF - -END SUBROUTINE binrwd - - -! ----- accurate summation ----(from mpnum) --------------------------------- - -!> Accurate summation. -!! -!! \param[in] add summand - -SUBROUTINE addsum(add) - USE mpmod - - IMPLICIT NONE - REAL(mpd):: add - INTEGER(mpi) ::nadd - ! ... - nadd=INT(add,mpi) ! convert to integer - accurateNsum=accurateNsum+nadd ! sum integer - accurateDsum=accurateDsum+(add-REAL(nadd,mpd)) ! sum remainder - IF(accurateDsum > 16.0_mpd) THEN ! + - 16 - accurateDsum=accurateDsum-16.0_mpd - accurateNsum=accurateNsum+16 - END IF - IF(accurateNsum > nexp20) THEN ! if > 2^20: + - 2^20 - accurateNexp=accurateNexp+1 - accurateNsum=accurateNsum-nexp20 - END IF - RETURN -END SUBROUTINE addsum - -!> Get accurate sum. -!! -!! \param[out] asum accurate sum - -SUBROUTINE getsum(asum) - USE mpmod - - IMPLICIT NONE - REAL(mpd), INTENT(OUT) ::asum - asum=(accurateDsum+REAL(accurateNsum,mpd))+REAL(accurateNexp,mpd)*REAL(nexp20,mpd) - accurateDsum=0.0_mpd - accurateNsum=0 - accurateNexp=0 - RETURN -END SUBROUTINE getsum diff --git a/millepede/randoms.f90 b/millepede/randoms.f90 deleted file mode 100644 index c5edbd0bde..0000000000 --- a/millepede/randoms.f90 +++ /dev/null @@ -1,199 +0,0 @@ - -! Code converted using TO_F90 by Alan Miller -! Date: 2012-03-16 Time: 11:09:33 - -!> \file -!! Random numbers. -!! -!! \author Volker Blobel, University Hamburg, 2005-2009 (initial Fortran77 version) -!! \author Claus Kleinwort, DESY (maintenance and developement) -!! -!! \copyright -!! Copyright (c) 2009 - 2015 Deutsches Elektronen-Synchroton, -!! Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n -!! 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. \n\n -!! 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. \n\n -!! You should have received a copy of the GNU Library General Public -!! License along with this program (see the file COPYING.LIB for more -!! details); if not, write to the Free Software Foundation, Inc., -!! 675 Mass Ave, Cambridge, MA 02139, USA. -!! -!! Random number generators for Uniform and Normal distribution: -!! -!! URAN() for U(0,1) -!! GRAN() for N(0,1) - -!> F.Gutbrod random number generator. -!! -!! Return N random numbers U(0,1) in array A(N). -!! Initialization by entry GBRVIN. -!! -!! \param[in] n number of requested random number -!! \param[out] a array of requested random number - -SUBROUTINE gbrshi(n,a) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: ian - INTEGER(mpi) :: iboost - INTEGER(mpi) :: ic - INTEGER(mpi) :: idum - INTEGER(mpi) :: irotor - INTEGER(mpi) :: iseed - INTEGER(mpi) :: it - INTEGER(mpi) :: iwarm - INTEGER(mpi) :: j - INTEGER(mpi) :: jseed - INTEGER(mpi) :: jwarm - INTEGER(mpi) :: k - INTEGER(mpi) :: m - INTEGER(mpi) :: mbuff - - INTEGER(mpi), INTENT(IN) :: n - REAL(mps), INTENT(OUT) :: a(*) - INTEGER(mpi), PARAMETER :: nb=511 - INTEGER(mpi), PARAMETER :: ia=16807 - INTEGER(mpi), PARAMETER :: im=2147483647 - INTEGER(mpi), PARAMETER :: iq=127773 - INTEGER(mpi), PARAMETER :: ir=2836 - REAL(mps), PARAMETER :: aeps=1.0E-10 - REAL(mps), PARAMETER :: scalin=4.6566125E-10 - COMMON/ranbuf/mbuff(0:nb),ian,ic,iboost - - INTEGER(mpi) :: istart - - irotor(m,n)=IEOR(ior(ishft(m,17),ishft(m,-15)),n) - DATA istart/0/,iwarm/10/,iseed/4711/ - IF(istart /= 0) GO TO 20 - WRITE(*,*) ' Automatic GBRSHI initialization using:' - ! initialize buffer -10 idum=iseed+9876543 ! prevent damage, if iseed=0 - WRITE(*,*) ' ISEED=',iseed,' IWARM=',iwarm - DO j=0,nb+1 ! fill buffer - k=idum/iq ! minimal standard generator - idum=ia*(idum-k*iq)-ir*k ! with Schrages method - IF(idum < 0) idum=idum+im ! - mbuff(j)=ishft(idum,1) ! fill in leading bit - END DO - ian=IAND(ian,nb) ! mask angle - ic=1 ! set pointer - iboost=0 - DO j=1,iwarm*nb ! warm up a few times - it=mbuff(ian) ! hit ball angle - mbuff(ian)=irotor(it,ic) ! new spin - ic=it ! replace red spin - ian=IAND(it+iboost,nb) ! boost and mask angle - iboost=iboost+1 ! increment boost - END DO - IF(istart < 0) RETURN ! return for RBNVIN - istart=1 ! set done-flag - ! generate array of r.n. - 20 DO i=1,n - it=mbuff(ian) ! hit ball angle - mbuff(ian)=irotor(it,ic) ! new spin - ic=it ! replace red spin - ian=IAND(it+iboost,nb) ! boost and mask angle - a(i)=REAL(ishft(it,-1),mps)*scalin+aeps ! avoid zero output - iboost=iboost+1 ! increment boost - END DO - iboost=IAND(iboost,nb) - RETURN - - ENTRY gbrvin(jseed,jwarm) ! initialize, but only once - IF(istart == 0) THEN - WRITE(*,*) ' Gbrshi initialization by GBRVIN-call using:' - iseed=jseed ! copy seed and - iwarm=jwarm ! warm-up parameter - istart=-1 ! start flag - GO TO 10 - END IF -END SUBROUTINE gbrshi - -!> GBRSHI initialization using TIME(). -SUBROUTINE gbrtim - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: jseed - REAL(mps) :: time - - LOGICAL :: done - DATA done/.FALSE./ - IF(done) RETURN - jseed=time() - WRITE(*,*) ' Gbrshi initialialization using Time()' - CALL gbrvin(jseed,10) - done=.TRUE. -END SUBROUTINE gbrtim - -!> Random number U(0,1) using RANSHI. -!! -!! \return random number U(0,1) - -REAL(mps) FUNCTION uran() ! U(0,1) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: indx - INTEGER(mpi) :: ndim - - PARAMETER (ndim=100) - REAL(mps) :: buffer(ndim) - DATA indx/ndim/ - SAVE indx,buffer - indx=MOD(indx,ndim)+1 - IF(indx == 1) CALL gbrshi(ndim,buffer) - uran=buffer(indx) -END FUNCTION uran - -!> Gauss random number. -!! -!! \return random number N(0,1) - -REAL(mps) FUNCTION gran() ! N(0,1) - USE mpdef - - IMPLICIT NONE - REAL(mps) :: al - REAL(mps) :: cs - INTEGER(mpi) :: indx - INTEGER(mpi) :: kn - INTEGER(mpi) :: ndim - REAL(mps) :: radsq - REAL(mps) :: rn1 - REAL(mps) :: rn2 - REAL(mps) :: sn - - PARAMETER (ndim=100) - REAL(mps) :: buffer(ndim) - DATA indx/ndim/,kn/1/ - SAVE indx,buffer,kn,cs,al - ! ... - IF(kn <= 1) THEN - ! two U(-1,+1) random numbers -10 indx=MOD(indx,ndim)+2 - IF(indx == 2) CALL gbrshi(ndim,buffer) - rn1=buffer(indx-1)-1.0+buffer(indx-1) - rn2=buffer(indx )-1.0+buffer(indx) - radsq=rn1*rn1+rn2*rn2 - IF(radsq > 1.0) GO TO 10 ! test point inside circle? - ! sine and cosine for random phi - sn=rn1/SQRT(radsq) - cs=rn2/SQRT(radsq) - ! transform to gaussians - al=SQRT(-2.0*LOG(radsq)) - kn =2 - gran=sn*al - ELSE - kn =1 - gran=cs*al - END IF -END FUNCTION gran diff --git a/millepede/readc.c b/millepede/readc.c deleted file mode 100644 index 46aa5653fe..0000000000 --- a/millepede/readc.c +++ /dev/null @@ -1,438 +0,0 @@ - -/** \file - * Read from C/C++ binary files. - * - * \author Gero Flucke, University Hamburg, 2006 - * \author Claus Kleinwort, DESY (maintenance and developement) - * - * \copyright - * Copyright (c) 2009 - 2015 Deutsches Elektronen-Synchroton, - * Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n - * 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. \n\n - * 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. \n\n - * You should have received a copy of the GNU Library General Public - * License along with this program (see the file COPYING.LIB for more - * details); if not, write to the Free Software Foundation, Inc., - * 675 Mass Ave, Cambridge, MA 02139, USA. - * - * C-methods to handle input of C/C++ binary files as input for - * the fortran **pede** program (see \ref peread). - * This includes macros utilising \c cfortran.h to allow direct callability - * from fortran. - * - * \c initC() has to be called once in the beginning, - * followed by one or several calls to \c openC() to open one or several files. - * \c readC() is then called to read the records sequentially. \c resetC() - * allows to rewind files. - * - * If compiled with preprocessor macro \c USE_SHIFT_RFIO, uses \c libRFIO, - * i.e. includes \c shift.h instead of \c stdio.h - * - * If compiled with preprocessor macro \c USE_ZLIB, uses \c libz, - * enables direct reading of gzipped files. - * - * Written by Gero Flucke (gero.flucke@cern.ch) in 2006/7 - * - update on July 14th, 2008 - * - update on October 29th, 2008: return for file number in \c readC() - * - * Major updates on April 24th, 2012 by C.Kleinwort: - * - skip records larger than buffer size (to determine max record length) - * - dynamic allocation of file pointer list (no hard-coded max number of files) - * - * Major update on February 26th, 2014 by C.Kleinwort: - * - implement reading of records containing doubles (instead of floats) - * indicated by negative record length. - * - * Last major update on April 10th, 2019 by C.Kleinwort: - * - Option to close and reopen files - */ - -#ifdef USE_SHIFT_RFIO -#include -// or this?? -// // needed?#define _LARGEFILE64_SOURCE -//#include -//#include "rfio_api.h" -#else -#include -#endif -#include "cfortran.h" -#ifdef USE_ZLIB -#include -#endif - -/* ________ global variables used for file handling __________ */ - -#ifdef USE_ZLIB -gzFile **files; ///< pointer to list of pointers to opened binary files -#else -FILE **files; ///< pointer to list of pointers to opened binary files -#endif - -unsigned int maxNumFiles; ///< max number of files -unsigned int numAllFiles; ///< number of opened files - -/*______________________________________________________________*/ -/// Initialises the 'global' variables used for file handling. -/** - * \param[in] nFiles Maximal number of C binary files to use. - */ -void initC(int *nFiles) { - maxNumFiles = *nFiles; -#ifdef USE_ZLIB - printf(" initC: using zlib version %s\n",ZLIB_VERSION); - files = (gzFile **) malloc(sizeof(gzFile *)*maxNumFiles); -#else - files = (FILE **) malloc(sizeof(FILE *) * maxNumFiles); -#endif - { - int i = 0; - for (; i < maxNumFiles; ++i) { - files[i] = 0; - } - } - numAllFiles = 0; -} -FCALLSCSUB1( initC, INITC, initc, PINT) - -/*______________________________________________________________*/ - -/* void rewinC() */ -/* { */ -/* /\* rewind all open files and start again with first file *\/ */ - -/* unsigned int i = numAllFiles; */ -/* while (i--) rewind(files[i]); /\* postfix decrement! *\/ */ -/* fileIndex = 0; */ -/* } */ -/* FCALLSCSUB0(rewinC,REWINC,rewinc) */ - -/*______________________________________________________________*/ -/// Rewind file. -/** - * \param[in] nFileIn File number (1 .. maxNumFiles) - */ -void resetC(int *nFileIn) { - int fileIndex = *nFileIn - 1; /* index of current file */ - if (fileIndex < 0) - return; /* no file opened at all... */ -#ifdef USE_ZLIB - gzrewind(files[fileIndex]); -#else - /* rewind(files[fileIndex]); Does not work with rfio, so call: */ - fseek(files[fileIndex], 0L, SEEK_SET); - clearerr(files[fileIndex]); /* These two should be the same as rewind... */ -#endif -} -FCALLSCSUB1( resetC, RESETC, resetc, PINT) - -/*______________________________________________________________*/ -/// Close file. -/** - * \param[in] nFileIn File number (1 .. maxNumFiles) - */ -void closeC(int *nFileIn) { - int fileIndex = *nFileIn - 1; /* index of current file */ - if (fileIndex < 0) - return; /* no file opened at all... */ -#ifdef USE_ZLIB - gzclose(files[fileIndex]); -#else - fclose(files[fileIndex]); -#endif - files[fileIndex] = 0; -} -FCALLSCSUB1( closeC, CLOSEC, closec, PINT) - -/*______________________________________________________________*/ -/// Open file. -void openC(const char *fileName, int *nFileIn, int *errorFlag) -/** - * \param[in] fileName File name - * \param[in] nFileIn File number (1 .. maxNumFiles) or <=0 for next one - * \param[out] errorFlag error flag: - * * 0: if file opened and OK, - * * 1: if too many files open, - * * 2: if file could not be opened - * * 3: if file opened, but with error (can that happen?) - */ -{ - /* No return value since to be called as subroutine from fortran */ - - if (!errorFlag) - return; /* 'printout' error? */ - - int fileIndex = *nFileIn - 1; /* index of specific file */ - if (fileIndex < 0) fileIndex = numAllFiles; /* next one */ - - if (fileIndex >= maxNumFiles) { - *errorFlag = 1; - } else { -#ifdef USE_ZLIB - files[fileIndex] = gzopen(fileName, "rb"); - if (!files[fileIndex]) { - *errorFlag = 2; - } else -#else - files[fileIndex] = fopen(fileName, "rb"); - if (!files[fileIndex]) { - *errorFlag = 2; - } else if (ferror(files[fileIndex])) { - fclose(files[fileIndex]); - files[fileIndex] = 0; - *errorFlag = 3; - } else -#endif - { - ++numAllFiles; /* We have one more opened file! */ - *errorFlag = 0; - } - } -} -FCALLSCSUB3( openC, OPENC, openc, STRING, PINT, PINT) - -/*______________________________________________________________*/ -/// Read record from file. -/** - * \param[out] bufferDouble read buffer for doubles - * \param[out] bufferFloat read buffer for floats - * \param[out] bufferInt read buffer for integers - * \param[in,out] lengthBuffers in: buffer length, out: number of floats/ints in records - * (> buffer size: record skipped) - * \param[in] nFileIn File number (1 .. maxNumFiles) - * \param[out] errorFlag error flag: - * * -1: pointer to a buffer or lengthBuffers are null - * * -2: problem reading record length - * * -4: given buffers too short for record - * * -8: problem with stream or EOF reading floats - * * -16: problem with stream or EOF reading ints - * * -32: problem with stream or EOF reading doubles - * * =0: reached end of file (or read empty record?!) - * * =4: found floats - * * =8: found doubles - */ -void readC(double *bufferDouble, float *bufferFloat, int *bufferInt, - int *lengthBuffers, int *nFileIn, int *errorFlag) { - /* No return value since to be called as subroutine from fortran, - negative *errorFlag are errors, otherwise fine. - - *nFileIn: number of the file the record is read from, - starting from 1 (not 0) - */ - int doublePrec = 0; - - if (!errorFlag) - return; - *errorFlag = 0; - int fileIndex = *nFileIn - 1; /* index of current file */ - if (fileIndex < 0) - return; /* no file opened at all... */ - if (!bufferFloat || !bufferInt || !lengthBuffers) { - *errorFlag = -1; - return; - } - - /* read length of 'record' */ - int recordLength = 0; /* becomes number of words following in file */ -#ifdef USE_ZLIB - int nCheckR = gzread(files[fileIndex], &recordLength, sizeof(recordLength)); - if (gzeof(files[fileIndex])) { - /* gzrewind(files[fileIndex]); CHK: moved to binrwd */ - *errorFlag = 0; /* Means EOF of file. */ - return; - } - if (recordLength<0) { - doublePrec = 1; - recordLength = -recordLength; - } - if (sizeof(recordLength) != nCheckR) { - printf("readC: problem reading length of record file %d\n", fileIndex); - *errorFlag = -2; - return; - } - - if (recordLength/2 > *lengthBuffers) { - /* printf("readC: given buffers too short (%d, need > %d)\n", *lengthBuffers, - recordLength/2); */ - /* skip floats */ - int i=0; - if (doublePrec) { - for (; i< recordLength/2; ++i) - { - int nCheckD = gzread(files[fileIndex], bufferDouble, sizeof(bufferDouble[0])); - if (nCheckD != sizeof(bufferDouble[0])) { - printf("readC: problem with stream or EOF skipping doubles\n"); - *errorFlag = -32; - return; - } - } - } else { - for (; i< recordLength/2; ++i) - { - int nCheckF = gzread(files[fileIndex], bufferFloat, sizeof(bufferFloat[0])); - if (nCheckF != sizeof(bufferFloat[0])) { - printf("readC: problem with stream or EOF skipping floats\n"); - *errorFlag = -8; - return; - } - } - } - i=0; - /* skip ints */ - for (; i< recordLength/2; ++i) - { - int nCheckI = gzread(files[fileIndex], bufferInt, sizeof(bufferInt[0])); - if (nCheckI != sizeof(bufferInt[0])) { - printf("readC: problem with stream or EOF skipping ints\n"); - *errorFlag = -16; - return; - } - } - - *errorFlag = -4; - *lengthBuffers = recordLength/2; - return; - } else { - *lengthBuffers = recordLength/2; - } - - /* read floats (i.e. derivatives + value + sigma) */ - if (doublePrec) { - int nCheckD = gzread(files[fileIndex], bufferDouble, *lengthBuffers*8); - if (nCheckD != *lengthBuffers*8) { - printf("readC: problem with stream or EOF reading doubles\n"); - *errorFlag = -32; - return; - } - } else { - int nCheckF = gzread(files[fileIndex], bufferFloat, *lengthBuffers*4); - if (nCheckF != *lengthBuffers*4) { - printf("readC: problem with stream or EOF reading floats\n"); - *errorFlag = -8; - return; - } - int i=0; - for (; i< recordLength/2; ++i) bufferDouble[i] = (double) bufferFloat[i]; - } - - /* read ints (i.e. parameter labels) */ - int nCheckI = gzread(files[fileIndex], bufferInt, *lengthBuffers*4); - if (nCheckI != *lengthBuffers*4) { - printf("readC: problem with stream or EOF reading ints\n"); - *errorFlag = -16; - return; - } -#else - size_t nCheckR = fread(&recordLength, sizeof(recordLength), 1, - files[fileIndex]); - if (feof(files[fileIndex])) { - /* rewind(files[fileIndex]); Does not work with rfio, so call: */ - /* fseek(files[fileIndex], 0L, SEEK_SET); CHK: moved to binrwd - clearerr(files[fileIndex]); These two should be the same as rewind... */ - *errorFlag = 0; /* Means EOF of file. */ - return; - } - - if (1 != nCheckR || ferror(files[fileIndex])) { - printf("readC: problem reading length of record, file %d\n", fileIndex); - *errorFlag = -2; - return; - } - - if (recordLength < 0) { - doublePrec = 1; - recordLength = -recordLength; - } - if (recordLength / 2 > *lengthBuffers) { - /* printf("readC: given buffers too short (%d, need > %d)\n", *lengthBuffers, - recordLength/2); */ - /* skip floats */ - int i = 0; - if (doublePrec) { - for (; i < recordLength / 2; ++i) { - size_t nCheckD = fread(bufferDouble, sizeof(bufferDouble[0]), 1, - files[fileIndex]); - if (ferror(files[fileIndex]) || feof(files[fileIndex]) - || nCheckD != *lengthBuffers) { - printf( - "readC: problem with stream or EOF skipping doubles\n"); - *errorFlag = -32; - return; - } - } - } else { - for (; i < recordLength / 2; ++i) { - size_t nCheckF = fread(bufferFloat, sizeof(bufferFloat[0]), 1, - files[fileIndex]); - if (ferror(files[fileIndex]) || feof(files[fileIndex]) - || nCheckF != *lengthBuffers) { - printf( - "readC: problem with stream or EOF skipping floats\n"); - *errorFlag = -8; - return; - } - } - } - i = 0; - /* skip ints */ - for (; i < recordLength / 2; ++i) { - size_t nCheckI = fread(bufferInt, sizeof(bufferInt[0]), 1, - files[fileIndex]); - if (ferror(files[fileIndex]) || feof(files[fileIndex]) - || nCheckI != *lengthBuffers) { - printf("readC: problem with stream or EOF skiping ints\n"); - *errorFlag = -16; - return; - } - } - - *errorFlag = -4; - *lengthBuffers = recordLength / 2; - return; - } else { - *lengthBuffers = recordLength / 2; - } - - /* read floats (i.e. derivatives + value + sigma) */ - if (doublePrec) { - size_t nCheckD = fread(bufferDouble, sizeof(bufferDouble[0]), - *lengthBuffers, files[fileIndex]); - if (ferror(files[fileIndex]) || feof(files[fileIndex]) - || nCheckD != *lengthBuffers) { - printf("readC: problem with stream or EOF reading doubles\n"); - *errorFlag = -32; - return; - } - } else { - size_t nCheckF = fread(bufferFloat, sizeof(bufferFloat[0]), - *lengthBuffers, files[fileIndex]); - if (ferror(files[fileIndex]) || feof(files[fileIndex]) - || nCheckF != *lengthBuffers) { - printf("readC: problem with stream or EOF reading floats\n"); - *errorFlag = -8; - return; - } - int i = 0; - for (; i < recordLength / 2; ++i) - bufferDouble[i] = (double) bufferFloat[i]; - } - /* read ints (i.e. parameter labels) */ - size_t nCheckI = fread(bufferInt, sizeof(bufferInt[0]), *lengthBuffers, - files[fileIndex]); - if (ferror(files[fileIndex]) || feof(files[fileIndex]) - || nCheckI != *lengthBuffers) { - printf("readC: problem with stream or EOF reading ints\n"); - *errorFlag = -16; - return; - } -#endif - - *errorFlag = 4 * (doublePrec + 1); -} -FCALLSCSUB6(readC,READC,readc,PDOUBLE,PFLOAT,PINT,PINT,PINT,PINT) diff --git a/millepede/tools/readMilleBinary.py b/millepede/tools/readMilleBinary.py deleted file mode 100755 index e5b21e26e2..0000000000 --- a/millepede/tools/readMilleBinary.py +++ /dev/null @@ -1,185 +0,0 @@ -#!/usr/bin32/python - -## \file -# Read millepede binary file and print records -# -# \author Claus Kleinwort, DESY, 2009 (Claus.Kleinwort@desy.de) -# -# \copyright -# Copyright (c) 2009 - 2018 Deutsches Elektronen-Synchroton, -# Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n -# 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. \n\n -# 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. \n\n -# You should have received a copy of the GNU Library General Public -# License along with this program (see the file COPYING.LIB for more -# details); if not, write to the Free Software Foundation, Inc., -# 675 Mass Ave, Cambridge, MA 02139, USA. -# -# Hardcoded defaults can be replaced by command line arguments for -# - Name of binary file -# - Number of records to print (-1: all; <-1: all, record headers only) -# - Number of records to skip (optional) -# - Mininum value to print derivative -# -# Description of the output from readMilleBinary.py -# - Records (tracks) start with \c '===' followed by record number and length -# (<0 for binary files containing doubles) -# - Measurements: A measurement with global derivatives is called a 'global measurement', -# otherwise 'local measurement'. Usually the real measurements from the detectors are 'global' -# ones and virtual measurements e.g. to describe multiple scattering are 'local'. -# - 'Global' measurements start with \c '-g-' followed by measurement number, first global label, -# number of local and global derivatives, measurement value and error. The next lines contain -# local and global labels (array('i')) and derivatives (array('f') or array('d')). -# - 'Local' measurements start with \c '-l-' followed by measurement number, first local label, -# number of local and global derivatives, measurement value and error. The next lines contain -# local labels (array('i')) and derivatives (array('f') or array('d')). -# -# Tested with SL4, SL5, SL6 - -import array, sys - -# ############### read millepede binary file ################# -# -## Binary file type (C or Fortran) -Cfiles = 1 # Cfiles -#Cfiles = 0 # Fortran files -# -## Integer format -intfmt = 'i' # SL5, gcc-4 -#intfmt = 'l' # SL4, gcc-3 -# -## Binary file name -fname = "milleBinaryISN.dat" -# -## number of records (tracks) to show -mrec = 10 -## number of records (track) to skip before -skiprec = 0 -## minimum value to print derivatives -minval = None # allows for NaNs -# -# ## C. Kleinwort - DESY ######################## - -# ## use command line arguments ? -narg = len(sys.argv) -if narg > 1: - if narg < 3: - print(" usage: readMilleBinary.py [ ]") - sys.exit(2) - else: - fname = sys.argv[1] - mrec = int(sys.argv[2]) - if narg > 3: - skiprec = int(sys.argv[3]) - if narg > 4: - minval = float(sys.argv[4]) - -#print " input ", fname, mrec, skiprec - -f = open(fname, "rb") - -nrec = 0 -try: - while (nrec < mrec + skiprec) or (mrec < 0): -# read 1 record - nr = 0 - if (Cfiles == 0): - lenf = array.array(intfmt) - lenf.fromfile(f, 2) - - length = array.array(intfmt) - length.fromfile(f, 1) - nr = abs(length[0] / 2) - nrec += 1 - - if length[0] > 0: - glder = array.array('f') - else: - glder = array.array('d') - glder.fromfile(f, nr) - - inder = array.array(intfmt) - inder.fromfile(f, nr) - - if (Cfiles == 0): - lenf = array.array(intfmt) - lenf.fromfile(f, 2) - - if (nrec <= skiprec): # must be after last fromfile - continue - - print(" === NR ", nrec, length[0] / 2) - - # no details, only header - if (mrec < -1): - continue - - i = 0 - nh = 0 - ja = 0 - jb = 0 - jsp = 0 - nsp = 0 - while (i < (nr - 1)): - i += 1 - while (i < nr) and (inder[i] != 0): i += 1 - ja = i - i += 1 - while (i < nr) and (inder[i] != 0): i += 1 - jb = i - i += 1 - # special data ? - if (ja + 1 == jb) and (glder[jb] < 0.): - jsp = jb - nsp = int(-glder[jb]) - i += nsp - 1 - print(' ### spec. ', nsp, inder[jsp + 1:i + 1], glder[jsp + 1:i + 1]) - continue - while (i < nr) and (inder[i] != 0): i += 1 - i -= 1 - nh += 1 - if (jb < i): -# measurement with global derivatives - print(' -g- meas. ', nh, inder[jb + 1], jb - ja - 1, i - jb, glder[ja], glder[jb]) - else: -# measurement without global derivatives - print(' -l- meas. ', nh, inder[ja + 1], jb - ja - 1, i - jb, glder[ja], glder[jb]) - if (ja + 1 < jb): - lab = [] - val = [] - for k in range(ja + 1, jb): - if minval is None: - lab.append(inder[k]) - val.append(glder[k]) - elif abs(glder[k]) >= minval: - lab.append(inder[k]) - val.append(glder[k]) - print(" local ", lab) - print(" local ", val) - if (jb + 1 < i + 1): - lab = [] - val = [] - for k in range(jb + 1, i + 1): - if minval is None: - lab.append(inder[k]) - val.append(glder[k]) - elif abs(glder[k]) >= minval: - lab.append(inder[k]) - val.append(glder[k]) - print(" global ", lab) - print(" global ", val) - -except EOFError: - print() - if (nr > 0): - print(" >>> error: end of file before end of record", nrec) - else: - print(" end of file after", nrec, "records") - -f.close() diff --git a/millepede/tools/readPedeHists.C b/millepede/tools/readPedeHists.C deleted file mode 100644 index 126010c278..0000000000 --- a/millepede/tools/readPedeHists.C +++ /dev/null @@ -1,600 +0,0 @@ -// -// |-------------------------------------------------------------------| -// ||-----------------------------------------------------------------|| -// || ROOT script to read the millepede.his file produced by pede || -// ||-----------------------------------------------------------------|| -// |-------------------------------------------------------------------| -// -// Author : Gero Flucke, University Hamburg, 2007 -// Date : July 2007 -// Last update: $Date: 2009/01/20 20:22:27 $ by $Author: flucke $ -// -// -// Usage: -// ====== -// -// Start ROOT and compile (!) the script: -// -// root [0] .L readPedeHists.C+ -// Info in : creating shared library ./readPedeHists_C.so -// -// If the millepede.his file is in the directory that ROOT was started in, just call -// -// root [1] readPedeHists() -// -// ROOT will display the histograms (TH1) and XY-data objects (TGraph). -// -// The following options and their combinations can be given as first argument: -// - print: produce a postscript file millepede.his.ps -// - write: write the histograms and graphs into the ROOT file millepede.his.root -// - nodraw: skip displaying (write/print work still fine) -// -// Note that both options 'print' and 'write' will overwrite existing files. -// -// If the millepede.his file has been renamed or is not in the local directory, -// its name can be given as second argument. The names of the postscript or ROOT files -// will be adjusted to the given name, too. -// -// The following example will read the file '../adir/millepede_result5.his' and directly -// produce the postscript file '../adir/millepede_result5.his.ps' without displaying and -// without producing a ROOT file: -// -// root [1] readPedeHists("print nodraw", "../adir/millepede_result5.his") -// Info in : ps file ../adir/millepede_result5.hisps has been created -// Info in : Current canvas added to ps file ../adir/millepede_result5.his.ps -// Info in : Current canvas added to ps file ../adir/millepede_result5.his.ps -// Info in : Current canvas added to ps file ../adir/millepede_result5.his.ps -// Info in : Current canvas added to ps file ../adir/millepede_result5.his.ps -// -// -// Possible modifications: -// ======================= -// - The size of the canvases is defined in ReadPedeHists::Draw() via 'nPixelX' and 'nPixelY'. -// - The number of histograms/graphs per canvas is defined in ReadPedeHists::Draw() as -// 'nHistX' and 'nHistY'. -// - The position of the corners of the boxes giving the minimum or maximum value of a -// histogrammed distribution is defined as the first four arguments after 'new TPaveText' -// at the end of the method ReadPedeHists::readNextHist. -// - gStyle->SetOptStat(...), executed before readPedeHists(), defines whether you see all -// relevant information in the statistics. Try e.g.: -// root [0] gStyle->SetOptStat("emrou"); // or "nemrou" -// - -#include -#include -#include // for std::pair -#include - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -//__________________________________________________________________________ -void readPedeHists(Option_t *option = "", const char *txtFile = "millepede.his");//"nodraw" skips drawing, "print" produces ps file, "write" writes object in ROOT file - -//__________________________________________________________________________ -//__________________________________________________________________________ -//__________________________________________________________________________ - -class ReadPedeHists -{ - public: - explicit ReadPedeHists(const char *txtFile); - ~ReadPedeHists() {} // non virtual: do not inherit from this class - void Draw(); // draw hists and graphs read from file - void Write(const char *rootFileName); // write hists/graphs to file - void Print(const char *printFileName); // if drawn, print into file, e.g. ps - - private: - template - bool readBasic(std::ifstream &aStream, T &outValue); - template - bool readBasicVector(std::ifstream &aStream, std::vector &outVector); - bool proceedTo(std::ifstream &aStream, const TString &pattern); - void readNumVersTypeTitle(std::ifstream &file, Int_t &num, Int_t &version, Int_t &type, - TString &title); - TH1 *readNextHist(std::ifstream &file); - std::pair readNextGraph(std::ifstream &file); - bool readNext(std::ifstream &file, TH1 *&hist, std::pair &graphOpt); - void read(std::ifstream &stream); - - std::ifstream theStream; - std::vector theHists; - std::vector > theGraphOpts; - std::vector theCanvases; -}; - -//__________________________________________________________________________ -ReadPedeHists::ReadPedeHists(const char *txtFile) : - theStream(txtFile, ios::in) -{ - if (!theStream.is_open()) { - ::Error("ReadPedeHists::ReadPedeHists", "file %s could not be opened", txtFile); - } else { - this->read(theStream); - } -} - - -//__________________________________________________________________________ -template -bool ReadPedeHists::readBasic(std::ifstream &aStream, T &outValue) -{ - while (true) { - const int aChar = aStream.get(); - if (!aStream.good()) return false; - - switch(aChar) { - case ' ': - case '\t': - case '\n': - if (aStream.eof()) return false; - continue; // to next character - default: - aStream.unget(); - aStream >> outValue; - if (aStream.fail()) {// not correct type 'T' (!aStream.good() is true also in case of EOF) - aStream.clear(); - return false; - } else { - return true; - } - } // switch - } // while - - ::Error("ReadPedeHists::readBasic", "Should never come here!"); - return false; -} - -//__________________________________________________________________________ -template -bool ReadPedeHists::readBasicVector(std::ifstream &aStream, std::vector &outVector) -{ - // vector must have desired size - for (unsigned int i = 0; i < outVector.size(); ++i) { - if (!readBasic(aStream, outVector[i])) return false; - } - - return true; -} - -//__________________________________________________________________________ -bool ReadPedeHists::proceedTo(std::ifstream &aStream, const TString &pattern) -{ - if (pattern.IsNull()) return true; - const char *method = "ReadPedeHists::proceedTo"; - - TString line; - do { - line.ReadLine(aStream); - if (line.Contains(pattern)) { - line.ReplaceAll(pattern, ""); - line.ReplaceAll(" ", ""); - if (!line.IsNull()) { - ::Warning(method, "line contains also '%s'", line.Data()); - } - return true; - } else { - ::Warning(method, "skipping line '%s'", line.Data()); - } - } while (!aStream.eof()); - - ::Error(method, "pattern '%s' not found", pattern.Data()); - return false; // did not find pattern -} - -//__________________________________________________________________________ -void ReadPedeHists::readNumVersTypeTitle(std::ifstream &file, Int_t &num, - Int_t &version, Int_t &type, TString &title) -{ - std::string key; // key word - - const char *method = "ReadPedeHists::readNumVersTypeTitle"; - if (!readBasic(file, num)) { - ::Error(method, "failed reading hist number"); - } - - if (!readBasic(file, key) || key != "version") { - ::Error(method, "expect key 'version', got '%s'", key.c_str()); - } - if (!readBasic(file, version)) { - ::Error(method, "failed reading version"); - } - - if (!readBasic(file, key) || key != "type") { - ::Error(method, "expect key 'type', got '%s'", key.c_str()); - } - if (!readBasic(file, type)) ::Error(method, "failed reading type"); - - title.ReadLine(file); // Title is a full line without key after the type! - Ssiz_t len = title.Length(); - while (len != kNPOS && len > 0 && title[--len] == ' ') {} // empty loop - title.Resize(len+1); // remove trailing space - title += Form(" (version %d)", version); -} - -//__________________________________________________________________________ -TH1 *ReadPedeHists::readNextHist(std::ifstream &file) -{ - // Key 'Histogram' assumed to be already read! - - // Until histogram title we have a fixed order to read in these numbers: - Int_t num = -1; // hist number - Int_t version = -1; // version (is it iteration?) - Int_t type = -1; // type, e.g. x-axis in log scale - TString title; // skip spaces?? - - const char *method = "ReadPedeHists::readNextHist"; // for errors/warnings - - readNumVersTypeTitle(file, num, version, type, title); - if (num == -1 || version == -1 || type == -1) { - ::Error(method, "Problems reading hist number, version or type, so skip it."); - proceedTo(file, "end of histogram"); - return 0; - } - // type 1: normal 1D histogram - // 2: 1D histogram with bins in log_10 - - // For the remaining information we accept any order, but there will be problems - // in case number of bins (key 'bins,') comes after 'bincontent'... - std::vector nBinsUpLow(3, -1.); // nBins (int...), lower and upper edge - std::vector underInOver(3, -1); // underflow : between lower/upper : overflow - std::vector binContent; // do not yet know length - Float_t min = 0., max = 0., mean = 0., sigma = 0.; // min/max of x-axis, mean/sigma of distrib. - - std::string key; // key word - while (readBasic(file, key)) { - if (key == "bins,") { - // read nBins with borders - if (!readBasic(file, key) || key != "limits") { - ::Error(method, "expect key 'limits', got (%s)", key.c_str()); - } else if (!readBasicVector(file, nBinsUpLow)) { - ::Error(method, "failed reading nBins, xLow, xUp (%f %f %f)", - nBinsUpLow[0], nBinsUpLow[1], nBinsUpLow[2]); - } else { - binContent.resize(static_cast(nBinsUpLow[0])); - } - } else if (key == "out-low") { - // read under-/overflow with what is 'in between' - if (!readBasic(file, key) || key != "inside" - || !readBasic(file, key) || key != "out-high") { - ::Error(method, "expected keys 'inside' and 'out-high', got (%s)", key.c_str()); - } else if (!readBasicVector(file, underInOver) || underInOver[0] == -1 - || underInOver[1] == -1 || underInOver[2] == -1) { - ::Error(method, "failed reading under-, 'in-' and overflow (%d %d %d)", - underInOver[0], underInOver[1], underInOver[2]); - } - } else if (key == "bincontent") { - // read bin content - problem if lenght not yet set! - if (nBinsUpLow[0] == -1.) { - ::Error(method, "n(bins) (key 'bins') not yet set, bin content cannot be read"); - } else if (!readBasicVector(file, binContent)) { - ::Error(method, "failed reading bincontent "); - } - } else if (key == "minmax") { - // read minimal and maximal x-value - if (!readBasic(file, min) || !readBasic(file, max)) { - ::Error(method, "failed reading min or max (%f %f)", min, max); - } - } else if (key == "meansigma") { - // read mean and sigma as calculated in pede - if (!readBasic(file, mean) || !readBasic(file, sigma)) { - ::Error(method, "failed reading mean or sigma (%f %f)", mean, sigma); - } - } else if (key == "end") { - // reached end - hopefully all has been read... - proceedTo(file, "of histogram"); - break; // ...the while reading the next key - } else { - ::Error(method, "unknown key '%s', try next word", key.c_str()); - } - } - - // now create histogram - if (nBinsUpLow[1] == nBinsUpLow[2]) { // causes ROOT drawing errors - nBinsUpLow[2] = nBinsUpLow[1] + 1.; - ::Error(method, "Hist %d (version %d): same upper and lower edge (%f), set upper %f.", - num, version, nBinsUpLow[1], nBinsUpLow[2]); - } - TH1 *h = new TH1F(Form("hist%d_version%d", num, version), title, - binContent.size(), nBinsUpLow[1], nBinsUpLow[2]); - h->SetBinContent(0, underInOver[0]); - for (UInt_t iBin = 1; iBin <= binContent.size(); ++iBin) { - h->SetBinContent(iBin, binContent[iBin - 1]); - } - h->SetBinContent(binContent.size() + 1, underInOver[2]); - h->SetEntries(underInOver[0] + underInOver[1] + underInOver[2]); - - if (type == 2) { - // could do more fancy stuff for nicer display... - h->SetXTitle("log_{10}"); - } else if (type != 1) { - ::Warning(method, "Unknown histogram type %d.", type); - } - - if (mean || sigma) { // overwrite ROOT's approximations from bin contents - Double_t stats[11] = {0.}; // no way to get this '11' from TH1... :-( - h->GetStats(stats); - stats[0] = stats[1] = h->GetEntries();// sum w and w^2 - stats[2] = mean * stats[0]; // sum wx - stats[3] = (sigma * sigma + mean * mean) * stats[0]; // sum wx^2 - h->PutStats(stats); - } - if (min || max) { - TPaveText *text = new TPaveText(.175, .675, .45, .875, "NDC"); - text->AddText(Form("min = %g", min)); - text->AddText(Form("max = %g", max)); - text->SetTextAlign(12); - text->SetBorderSize(1); - h->GetListOfFunctions()->Add(text);// 'hack' to get it drawn with the hist - } - - return h; -} - -//__________________________________________________________________________ -std::pair ReadPedeHists::readNextGraph(std::ifstream &file) -{ - // graph and drawing option... - // Key 'XY-Data' assumed to be already read! - - TGraph *graph = 0; - Option_t *drawOpt = 0; // fine to use simple pointer since assigned only hardcoded strings - - // Until graph title we have a fixed order to read in these numbers: - Int_t num = -1; // graph number - Int_t version = -1; // version (is it iteration?) - Int_t type = -1; // cf. below - TString title; - - const char *method = "ReadPedeHists::readNextGraph"; // for errors/warnings - - readNumVersTypeTitle(file, num, version, type, title); - if (num == -1 || version == -1 || type == -1) { - ::Error(method, "Problems reading graph number, version or type, so skip it."); - proceedTo(file, "end of xy-data"); - return std::make_pair(graph, drawOpt); - } - // graph types: 1 dots (x,y) - // 2 polyline - // 3 dots and polyline - // 4 symbols with (x,y) and dx, dy - // 5 same as 5 - if (type < 1 || type > 5) { - ::Error(method, "Unknown xy-data type %d, so skip graph.", type); - proceedTo(file, "end of xy-data"); - } - - // now read number of points and content - UInt_t numPoints = 0; - std::vector content; // do not yet know length (need two/four values per point!) - - std::string key; - while (readBasic(file, key)) { - if (key == "stored") { - if (!readBasic(file, key) || key != "not-stored") { - ::Error(method, "expected key 'not-stored', got '%s'", key.c_str()); - } else if (!readBasic(file, numPoints)) { - ::Error(method, "failed reading number of points (%d)", numPoints); - } - } else if (key == "x-y") { - if (type < 1 || type > 3) { - ::Error(method, "expect key x-y-dx-dy for type %d, found x-y", type); - } - content.resize(numPoints * 2); - if (!readBasicVector(file, content) || !numPoints) { - ::Error(method, "failed reading x-y content%s", - (!numPoints ? " since n(points) (key 'stored') not yet set" : "")); - } - } else if (key == "x-y-dx-dy") { - if (type < 4 || type > 5) { - ::Error(method, "expect key x-y for type %d, found x-y-dx-dy", type); - } - content.resize(numPoints * 4); - if (!readBasicVector(file, content) || !numPoints) { - ::Error(method, "failed reading x-y-dx-dy content%s", - (!numPoints ? " since n(points) (key 'stored') not yet set" : "")); - } - } else if (key == "end") { - proceedTo(file, "of xy-data"); - break; - } else { - break; - ::Error(method, "unknown key '%s', try next word", key.c_str()); - } - } - - // now create TGraph(Error) and fill drawOpt - if (type == 4 || type == 5) { - TGraphErrors *graphE = new TGraphErrors(numPoints); - for (unsigned int i = 0; i < content.size(); i += 4) { - graphE->SetPoint (i/4, content[i] , content[i+1]); - graphE->SetPointError(i/4, content[i+2], content[i+3]); - } - drawOpt = "AP"; - graph = graphE; - } else if (type >= 1 && type <= 3) { - graph = new TGraph(numPoints); - for (unsigned int i = 0; i < content.size(); i += 2) { - graph->SetPoint(i/2, content[i], content[i+1]); - } - if (type == 1) { - drawOpt = "AP"; - } else if (type == 2) { - drawOpt = "AL"; - } else if (type == 3) { - drawOpt = "ALP"; - } - if (TString(drawOpt).Contains("P")) graph->SetMarkerStyle(20); // - } // 'else' not needed, tested above - - if (graph) graph->SetNameTitle(Form("graph%d_version%d", num, version), title); - return std::make_pair(graph, drawOpt); -} - -//__________________________________________________________________________ -bool ReadPedeHists::readNext(std::ifstream &file, TH1 *&hist, - std::pair &graphOpt) -{ - hist = 0; - graphOpt.first = 0; - graphOpt.second = 0; - - TString type; - while (true) { - if (file.eof()) break; - file >> type; - if (file.fail() || (type != "Histogram" && type != "XY-Data")) { - TString line; - line.ReadLine(file); - if (line != "" && line.Length() != line.CountChar(' ')) { // not empty - ::Error("ReadPedeHists::readNext", - "Expect 'Histogram' or 'XY-Data', but failed, line is '%s'", - line.Data()); - if (proceedTo(file, "end of")) line.ReadLine(file); // just skip rest of line... - } - } - - if (type == "Histogram") hist = readNextHist(file); - if (type == "XY-Data") graphOpt = readNextGraph(file); - if (hist || graphOpt.first) break; - } - - return (hist || graphOpt.first); -} - -//__________________________________________________________________________ -void ReadPedeHists::read(std::ifstream &file) -{ - theHists.clear(); - theGraphOpts.clear(); - - TH1 *hist = 0; - std::pair graphOpt(0,0); // graph and its drawing option - while (readNext(file, hist, graphOpt)) { - if (hist) theHists.push_back(hist); - if (graphOpt.first) theGraphOpts.push_back(graphOpt); - } -} - -//__________________________________________________________________________ -void ReadPedeHists::Draw() -{ - theCanvases.clear(); // memory leak? - - const Int_t nHistX = 3; - const Int_t nPixelX = 700; - const Int_t nHistY = 2; - const Int_t nPixelY = 500; - Int_t last = nHistX * nHistY; - unsigned int iH = 0; - - while (iH < theHists.size()) { - if (last >= nHistX * nHistY) { - unsigned int canCorner = theCanvases.size() * 20; - theCanvases.push_back(new TCanvas(Form("hists%d", iH), "", - canCorner, canCorner, nPixelX, nPixelY)); - theCanvases.back()->Divide(nHistX, nHistY); - last = 0; - } - theCanvases.back()->cd(++last); - theHists[iH]->Draw(); - ++iH; - } - - last = nHistX * nHistY; - iH = 0; - while (iH < theGraphOpts.size()) { - if (last >= nHistX * nHistY) { - unsigned int canCorner = theCanvases.size() * 20; - theCanvases.push_back(new TCanvas(Form("graphs%d", iH), "", - canCorner, canCorner, nPixelX, nPixelY)); - theCanvases.back()->Divide(nHistX, nHistY); - last = 0; - } - theCanvases.back()->cd(++last); - theGraphOpts[iH].first->Draw(theGraphOpts[iH].second); - ++iH; - } -} - -//__________________________________________________________________________ -void ReadPedeHists::Print(const char *printFileName) -{ - std::vector::iterator iC = theCanvases.begin(), iE = theCanvases.end(); - if (iC == iE) return; // empty... - - theCanvases.front()->Print(Form("%s[", printFileName)); // just open ps - while(iC != iE) { - (*iC)->Print(printFileName); - ++iC; - } - theCanvases.front()->Print(Form("%s]", printFileName)); // just close ps - -} - -//__________________________________________________________________________ -void ReadPedeHists::Write(const char *rootFileName) -{ - if (theHists.empty() && theGraphOpts.empty()) return; - - ::Info("ReadPedeHists::Write", "(Re-)Creating ROOT file %s.", rootFileName); - - TDirectory *oldDir = gDirectory; - TFile *rootFile = TFile::Open(rootFileName, "RECREATE"); - - for (std::vector::iterator iH = theHists.begin(), iE = theHists.end(); - iH != iE; ++iH) { - (*iH)->Write(); - } - - for (std::vector >::iterator iG = theGraphOpts.begin(), - iE = theGraphOpts.end(); iG != iE; ++iG) { - (*iG).first->Write(); - } - - delete rootFile; - oldDir->cd(); -} - -//__________________________________________________________________________ -//__________________________________________________________________________ -//__________________________________________________________________________ -void readPedeHists(Option_t *option, const char *txtFile) -{ - ReadPedeHists reader(txtFile); - TString opt(option); - opt.ToLower(); - - const bool oldBatch = gROOT->IsBatch(); - if (opt.Contains("nodraw")) { - opt.ReplaceAll("nodraw", ""); - gROOT->SetBatch(true); - } - - reader.Draw(); - - if (opt.Contains("print")) { - opt.ReplaceAll("print", ""); - reader.Print(TString(Form("%s.ps", txtFile))); - } - - if (opt.Contains("write")) { - opt.ReplaceAll("write", ""); - reader.Write(TString(Form("%s.root", txtFile))); - } - - gROOT->SetBatch(oldBatch); - opt.ReplaceAll(" ", ""); - if (!opt.IsNull()) { - ::Warning("readPedeHists", "Unknown option '%s', know 'nodraw', 'print' and 'write'.", - opt.Data()); - } -} diff --git a/millepede/vertpr.f90 b/millepede/vertpr.f90 deleted file mode 100644 index a2428062f0..0000000000 --- a/millepede/vertpr.f90 +++ /dev/null @@ -1,278 +0,0 @@ - -! Code converted using TO_F90 by Alan Miller -! Date: 2012-03-16 Time: 11:09:42 - -!> \file -!! Print vertical. -!! -!! \author Volker Blobel, University Hamburg, 2005-2009 (initial Fortran77 version) -!! \author Claus Kleinwort, DESY (maintenance and developement) -!! -!! \copyright -!! Copyright (c) 2009 - 2015 Deutsches Elektronen-Synchroton, -!! Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n -!! 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. \n\n -!! 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. \n\n -!! You should have received a copy of the GNU Library General Public -!! License along with this program (see the file COPYING.LIB for more -!! details); if not, write to the Free Software Foundation, Inc., -!! 675 Mass Ave, Cambridge, MA 02139, USA. -!! - -!> Print vertical. -!! -!! Print the array X of dimension N (MAX 120) in 6 lines. -!! -!! \param[in] n number of numbers -!! \param[in] x array of numbers - -SUBROUTINE pzvert(n,x) - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: i1 - INTEGER(mpi) :: i2 - INTEGER(mpi) :: ia - INTEGER(mpi) :: ij - INTEGER(mpi) :: im - INTEGER(mpi) :: in - INTEGER(mpi) :: iz - INTEGER(mpi) :: j - INTEGER(mpi) :: jl - INTEGER(mpi) :: jm - INTEGER(mpi) :: ke - INTEGER(mpi) :: kl - INTEGER(mpi) :: kn - INTEGER(mpi) :: lc - INTEGER(mpi) :: m - INTEGER(mpi) :: mx - REAL(mps) :: fac - REAL(mps) :: xm - ! - - INTEGER(mpi), INTENT(IN) :: n - REAL(mps), INTENT(IN) :: x(n) - INTEGER(mpi), PARAMETER :: nn=6 - - CHARACTER (LEN=66):: px(10) - CHARACTER (LEN=66)::ch(10)*1 - SAVE - DATA ch/'0','1','2','3','4','5','6','7','8','9'/ - ! ... - IF(n <= 0) RETURN - jm=0 - DO i=1,10 - px(i)=' ' - END DO - - m=MIN(60,n) - jl=0 - xm=0.0 - DO j=1,m - IF(ABS(x(j)) > xm) THEN - xm=ABS(x(j)) - mx=j ! index of max - END IF - IF(x(j) < 0.0) px(1)(6+j:6+j)='-' ! negative columns - IF(x(j) /= 0.0) jl=j ! last non-zero column - END DO - IF(xm == 0.0.OR.jl <= 0) RETURN ! empty array - jl=60 - - kn=MIN(6,MAX(2,IABS(nn))) - ke=INT(LOG10(xm*1.0001),mpi) - IF(xm < 1.0) ke=ke-1 -22 fac=10.0**(kn-1-ke) - ij=NINT(fac*xm,mpi) - IF(ij >= 10**kn) THEN - ke=ke+1 - GO TO 22 - END IF - ia=2+kn - - DO j=1,jl - ij=NINT(fac*ABS(x(j)),mpi) ! convert to integer - im=0 - IF(ij /= 0) THEN - DO i=1,kn - IF(ij /= 0) THEN - in=MOD(ij,10) ! last digit - ij=ij/10 ! reduce - IF(in /= 0.AND.im == 0) im=ia-i+1 - px(ia-i)(6+j:6+j)=ch(in+1) - END IF - END DO - END IF - jm=MAX(im,jm) - END DO - - kl=ke -50 IF(ke >= kn) THEN - ke=ke-3 - GO TO 50 - END IF -55 IF(ke < 0) THEN - ke=ke+3 - GO TO 55 - END IF - - in=ke+2 ! exponent - iz=kl-ke - px(in)(6:6)='.' - px(in)(1:1)='E' - IF(iz < 0) THEN - px(in)(2:2)='-' - iz=-iz - END IF - i1=iz/10 ! insert exponent - i2=MOD(iz,10) - px(in)(3:3)=ch(i1+1) - px(in)(4:4)=ch(i2+1) - jm=MIN(2+kn,jm) - jm=MAX(in+1,jm) - DO j=1,jl ! '0' for small nonzero values - IF(x(j) /= 0.0.AND.px(jm-1)(6+j:6+j) == ' ') px(jm-1)(6+j:6+j)='0' - END DO - DO i=jm,8 - px(i)=' ' - END DO - - DO j=1,((jl+9)/10)*10 ! index line below - IF(px(jm-1)(6+j:6+j) == ' ') px(jm-1)(6+j:6+j)='_' - IF(MOD(j,2) /= 1) THEN - i=MOD(j,10)+1 - px(jm+1)(6+j:6+j)=ch(i) ! last digit of even bin numbers - IF(i == 1) THEN ! ten'th column - i=MOD(j/10,10)+1 - px(jm)(6+j:6+j)=ch(i) - - END IF - END IF - END DO - - DO j=1,jl - IF(x(j) == x(mx)) THEN - px(jm)(6+j:6+j)='*' ! * in max bin - END IF - END DO - - jm=jm+1 - IF(nn < 0) jm=jm-2 ! no index line - lc=((jl+9)/10)*10+6 - DO j=1,jm - WRITE(*,*) px(j)(1:lc) ! print - ! WRITE(*,101) PX(J)(1:LC) ! print - END DO - RETURN -! 101 FORMAT(A) -END SUBROUTINE pzvert - -!> Vertical print of integer data. -!! -!! Print in up to 60 columns. Optionally average data. -!! -!! \param[in] n number of integers -!! \param[in] list array of integers - -SUBROUTINE pivert(n,list) ! - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - INTEGER(mpi) :: l - INTEGER(mpi) :: ll - INTEGER(mpi) :: m - INTEGER(mpi) :: nhist - - INTEGER(mpi), INTENT(IN) :: n - INTEGER(mpi), INTENT(IN) :: list(n) - - - REAL(mps) :: y(60) - - SAVE - ! ... - ll=(n+59)/60 ! compression factor - m=0 - i=0 -10 nhist=0 - DO l=1,ll - IF(i+l <= n) nhist=nhist+list(i+l) - END DO - i=i+ll - m=m+1 - y(m)=nhist - IF(i < n) GO TO 10 - CALL pzvert(m,y) - RETURN -END SUBROUTINE pivert - -!> Vertical print of floating point data. -!! -!! Print in up to 60 columns. Optionally average data. -!! -!! \param[in] n number of floats -!! \param[in] x array of floats - -SUBROUTINE pfvert(n,x) ! vert. print fltpt data - USE mpdef - - IMPLICIT NONE - REAL(mps) :: dsum - INTEGER(mpi) :: i - INTEGER(mpi) :: l - INTEGER(mpi) :: ll - INTEGER(mpi) :: m - REAL(mps) :: y(60) - - INTEGER(mpi), INTENT(IN) :: n - INTEGER(mpi), INTENT(IN) :: x(n) - - ll=(n+59)/60 ! compression factor - m=0 - i=0 -20 dsum=0.0 - DO l=1,ll - IF(i+l <= n) dsum=dsum+x(i+l) - END DO - i=i+ll - m=m+1 - y(m)=REAL(dsum,mps) - IF(i < n) GO TO 20 - CALL pzvert(m,y) - RETURN -END SUBROUTINE pfvert - -!> Print scale. -!! -!! \param[in] xa lower bound of range -!! \param[in] xb upper bound of range - -SUBROUTINE psvert(xa,xb) ! print scale - USE mpdef - - IMPLICIT NONE - INTEGER(mpi) :: i - REAL(mps) :: xc - ! print scale from XA ... XB - - - REAL(mps), INTENT(IN) :: xa - REAL(mps), INTENT(IN) :: xb - REAL(mps) :: sc(7) - xc=xb - DO i=1,7 - sc(i)=(REAL(7-i,mps)*xa+REAL(i-1,mps)*xc)/6.0 - END DO - WRITE(*,101) sc -101 FORMAT(3X,7G10.3) - RETURN -END SUBROUTINE psvert -